diff options
author | Ian Lance Taylor <iant@golang.org> | 2021-10-07 15:28:36 -0700 |
---|---|---|
committer | Ian Lance Taylor <iant@golang.org> | 2021-10-07 15:28:36 -0700 |
commit | 0b6b70a0733672600644c8df96942cda5bf86d3d (patch) | |
tree | 9a1fbd7f782c54df55ab225ed1be057e3f3b0b8a /gcc/ada | |
parent | a5b5cabc91c38710adbe5c8a2b53882abe994441 (diff) | |
parent | fba228e259dd5112851527f2dbb62c5601100985 (diff) | |
download | gcc-0b6b70a0733672600644c8df96942cda5bf86d3d.zip gcc-0b6b70a0733672600644c8df96942cda5bf86d3d.tar.gz gcc-0b6b70a0733672600644c8df96942cda5bf86d3d.tar.bz2 |
Merge from trunk revision fba228e259dd5112851527f2dbb62c5601100985.
Diffstat (limited to 'gcc/ada')
195 files changed, 18249 insertions, 5882 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 56d9baf..feadd5e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,1734 @@ +2021-10-05 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (gnat_to_gnu): Do not wrap boolean values + referenced in pragmas. + +2021-10-05 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Do not set the + DECL_DISREGARD_INLINE_LIMITS flag if -gnatd.8 is specified. + +2021-10-05 Bob Duff <duff@adacore.com> + + * gcc-interface/trans.c (set_end_locus_from_node): Check that + Handled_Statement_Sequence is not Empty before calling + End_Label, because the Empty node has no End_Label, and + depending on the exact node layout chosen by gen_il, calling + End_Label might crash, or might work OK by accident. + +2021-10-05 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/cuintp.c: Adjust placement of include directive. + * gcc-interface/targtyps.c: Likewise. + +2021-10-05 Alexandre Oliva <oliva@adacore.com> + + * doc/gnat_rm.rst: Add... + * doc/gnat_rm/security_hardening_features.rst: New. + * doc/gnat_rm/about_this_guide.rst: Link to new chapter. + * gnat_rm.texi: Regenerate. + * gcc-interface/utils.c (handle_strub_attribute): New. + (gnat_internal_attribute_table): Add strub. + * libgnat/a-except.adb: Make Rcheck_CE_* strub-callable. + * libgnat/a-except.ads (Raise_Exception): Likewise. + (Raise_Exception_Always): Likewise. + * libgnat/s-arit128.ads (Multiply_With_Ovflo_Check128): + Likewise. + * libgnat/s-arit64.ads (Multiply_With_Ovflo_Check64): + Likewise. + * libgnat/s-secsta.ads (SS_Allocate, SS_Mark, SS_Release): + Likewise. + +2021-10-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch9.adb (Install_Private_Data_Declarations): Copy the Sloc of + components for the local renamings as well as the Comes_From_Source + flag, and also set Warnings_Off on them. Use Nam local variable. + +2021-10-05 Arnaud Charlet <charlet@adacore.com> + + * libgnarl/a-tasini.ads (Set_Initialization_Handler): Update + comments. + +2021-10-05 Corentin Gay <gay@adacore.com> + + * init.c (QNX): Add #include errno.h. + +2021-10-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_attr.adb (Expand_Fpt_Attribute): Likewise. + * snames.ads-tmpl (Name_Unaligned_Valid): Delete. + +2021-10-05 Etienne Servais <servais@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Forbid use of + Compile_Time_(Error|Warning) as configuration pragma. + * doc/gnat_ugn/the_gnat_compilation_model.rst: + Compile_Time_(Error|Warning) and Compiler_Unit(_Warning) are not + configuration pragmas and shall not be listed as such. The + following pragmas are either obsolete or undocumented: + No_Run_Time, Propagate_Exceptions, Rational, Ravenscar, + Restricted_Run_Time, Short_Descriptors, Universal_Data. Fix + some typos (notably on Restriction_Warnings). + * doc/gnat_rm/implementation_defined_pragmas.rst: Move + Rename_Pragma documentation to alphabetical order. + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + +2021-10-05 Corentin Gay <gay@adacore.com> + + * adaint.c (QNX): Add #include for sys/time.h. + +2021-10-05 Pascal Obry <obry@adacore.com> + + * libgnat/g-forstr.adb (Next_Format): When there is no more + format specifier found issue a proper error message instead of + raising a contraint error. + +2021-10-05 Pascal Obry <obry@adacore.com> + + * libgnat/g-forstr.adb (Get_Formatted): Fix computation of the + number of zero to use in the formatted string. This was a wrong + copy/paste. + +2021-10-05 Pascal Obry <obry@adacore.com> + + * libgnat/g-forstr.adb (Get_Formatted): Minor code clean-up. + +2021-10-05 Etienne Servais <servais@adacore.com> + + * libgnat/a-zchhan.ads, libgnat/a-zchhan.adb + (Character_Set_Version, Is_Basic, To_Basic): New. + * libgnat/a-zchuni.ads, libgnat/a-zchuni.adb (Is_Basic, + To_Basic): New. + +2021-10-05 Yannick Moy <moy@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Improve error message. + +2021-10-05 Gary Dismukes <dismukes@adacore.com> + + * aspects.ads (type Aspect_Id): Add + Aspect_Designated_Storage_Model and Aspect_Storage_Model_Type. + (Aspect_Argument): Add associations for the above new aspects. + (Is_Representation_Aspect): Likewise. + (Aspect_Names, Aspect_Delay): Likewise. + * exp_ch4.adb (Expand_N_Allocator): Call Find_Storage_Op rather + than Find_Prim_Op. + * exp_intr.adb (Expand_Unc_Deallocation): Likewise. + * exp_util.ads (Find_Storage_Op): New function that locates + either a primitive operation of a storage pool or an operation + of a storage-model type specified in its Storage_Model_Type + aspect. + * exp_util.adb (Find_Storage_Op): New function that calls either + Find_Prim_Op or Get_Storage_Model_Type_Entity to locate a + storage-related operation that is associated with a type. + * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Analyzes, + resolves, and validates the arguments of aspect + Designated_Storage_Model_Type. + (Analyze_Aspect_Specifications): Sets delay-related flags on + storage-model aspects when Delay_Required. Checks that aspect + Designated_Storage_Model is only specified for an access type + and that aspect Storage_Model_Type is only specified on an + immutably limited type. Also records such aspects for their + associated types. + (Check_Aspect_At_Freeze_Point): Resolve each of the argument + associations given for a Storage_Model_Type aspect. + (Resolve_Storage_Model_Type_Argument): New procedure that + resolves an argument given in the association for a given entity + name associated with a type with aspect Storage_Model_Type, + ensuring that it has the proper kind or profile. + (Validate_Storage_Model_Type_Aspect): New procedure that checks + the legality and completeness of the entity associations given + in a Storage_Model_Type aspect. + * sem_util.ads (package Storage_Model_Support): New nested + package that encapsulates a set of convenient utility functions + for retrieving entities, etc. associated with + storage-model-related types and objects. + (Get_Storage_Model_Type_Entity): New function to return a + specified entity associated with a type that has aspect + Storage_Model_Type. + (Has_Designated_Storage_Model_Aspect): New function that returns + whether a type has aspect Designated_Storage_Model. + (Has_Storage_Model_Type_Aspect): New function that returns + whether a type has aspect Storage_Model_Type. + (Storage_Model_Object): New function that returns the object + Entity_Id associated with a type's Designated_Storage_Model + aspect. + (Storage_Model_Type): New function that returns the type + associated with a storage-model object (when the object's type + specifies Storage_Model_Type). + (Storage_Model_Address_Type): New function that returns the + Address_Type associated with a type that has aspect + Storage_Model_Type. + (Storage_Model_Null_Address): New function that returns the + Null_Address constant associated with a type that has aspect + Storage_Model_Type. + (Storage_Model_Allocate): New function that returns the Allocate + procedure associated with a type that has aspect + Storage_Model_Type. + (Storage_Model_Deallocate): New function that returns the + Deallocate procedure associated with a type that has aspect + Storage_Model_Type. + (Storage_Model_Copy_From): New function that returns the + Copy_From procedure associated with a type that has aspect + Storage_Model_Type. + (Storage_Model_Copy_To): New function that returns the Copy_To + procedure associated with a type that has aspect + Storage_Model_Type. + (Storage_Model_Storage_Size): New function that returns the + Storage_Size function associated with a type that has aspect + Storage_Model_Type. + * sem_util.adb (package Storage_Model_Support): Body of new + nested package that contains the implementations the utility + functions declared in the spec of this package. + * snames.ads-tmpl: Add new names Name_Designated_Storage_Pool, + Name_Storage_Model, Name_Storage_Model_Type, Name_Address_Type, + Name_Copy_From, Name_Copy_To, and Name_Null_Address for the new + aspects and associated aspect arguments. + +2021-10-05 Richard Kenner <kenner@adacore.com> + + * debug.adb: Add documentation for -gnatd_t. + +2021-10-05 Corentin Gay <gay@adacore.com> + + * sysdep.c (__gnat_is_file_not_found_error): Add else if case. + +2021-10-05 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.adb (Build_Class_Wide_Expression): Replace entities + of both identifiers and operator symbols. + +2021-10-05 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch3.adb (Derive_Subprogram): Copy ghost status from parent + to derived subprogram. + +2021-10-05 Joffrey Huguet <huguet@adacore.com> + + * libgnat/a-strunb.ads, libgnat/a-strunb__shared.ads: Add + Default_Initial_Condition to Unbounded_String. + +2021-10-05 Claire Dross <dross@adacore.com> + + * libgnat/a-cfdlli.ads: Use pragma Assertion_Policy to disable + contract cases at execution. + * libgnat/a-cfinve.ads: Idem. + * libgnat/a-cofove.ads: Idem. + * libgnat/a-cfhase.ads: Idem. + * libgnat/a-cfhama.ads: Idem. + * libgnat/a-cforse.ads: Idem. + * libgnat/a-cforma.ads: Idem. + +2021-10-05 Bob Duff <duff@adacore.com> + + * par-ch4.adb (P_Iterated_Component_Association): Parse these + features the same way in all language versions. Move the call + to Error_Msg_Ada_2022_Feature into semantic analysis. + * sem_aggr.adb (Resolve_Iterated_Component_Association, + Resolve_Iterated_Association): Move the call to + Error_Msg_Ada_2022_Feature here from par-ch4.adb. + +2021-10-05 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve): Recognize specially that case. + +2021-10-05 Yannick Moy <moy@adacore.com> + + * libgnat/a-strmap.adb: Add ghost code for proof. + (To_Range): This is the most involved proof, as it requires + creating the result of the call to To_Domain as a ghost + variable, and show the unicity of this result in order to prove + the postcondition. + * libgnat/a-strmap.ads: (SPARK_Proof_Sorted_Character_Sequence): + New ghost function. + (To_Domain): Add postcondition regarding sorting of result. + (To_Range): Fix postcondition that should compare Length instead + of Last for the results of To_Domain and To_Range, as the value + of Last for an empty result is not specified in the Ada RM. + +2021-10-05 Yannick Moy <moy@adacore.com> + + * libgnat/a-chahan.adb: Add loop invariants as needed to prove + subprograms. Also use extended return statements where + appropriate and not done already. Mark data with + Relaxed_Initialization where needed for initialization by parts. + Convert regular functions to expression functions where needed + for proof. + * libgnat/a-chahan.ads: Add postconditions. + * libgnat/a-strmap.ads (Model): New ghost function to create a + publicly visible model of the private data Character_Mapping, + needed in order to prove subprograms in Ada.Characters.Handling. + +2021-10-04 Justin Squirek <squirek@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst: + Add new entry for No_Dynamic_Accessibility_Checks documenting + behavior. + * gnat_rm.texi: Regenerate. + * exp_ch4.adb (Expand_N_In): Perform special expansion for + membership tests when No_Dynamic_Accessibility_Checks is active. + * sem_attr.adb (Resolve_Attribute): Skip static accessibility + check on actuals for anonymous access type formal parameters, + and add constants for readability. + * sem_util.adb (Function_Call_Or_Allocator_Level): Use the + innermost master for determining the level for function calls + within the alternative accessibility model. + (Type_Access_Level): Properly get the level for anonymous access + function result types. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst + (gnateA): This switch no longer looks at the formal parameter + type being composite (as originally mandated by SPARK), but in + the parameter passing mechanism being not specified (as + currently mandated by Ada). + * gnat_ugn.texi: Regenerate. + +2021-10-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Operator_Symbol): Recognize strings as + operator names when they are the value of one of the Ada2022 + aspects for User_Defined_Literals. + * sem_ch13.adb (Analyze_One_Aspect): Handle an aspect value + given by an Operator_Name. + (Validate_Literal_Aspect): Call Analyze_Operator_Symbol when + needed. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * gen_il-gen.adb (Put_Make_Spec): Don't emit the LF character in + the middle of a string, because the Put routine won't indent it + properly. + +2021-10-04 Ghjuvan Lacambre <lacambre@adacore.com> + + * gnat_cuda.adb (Remove_CUDA_Device_Entities): New function. + (Expand_CUDA_Package): Call Remove_CUDA_Device_Entities. + * gnat_cuda.ads (Expand_CUDA_Package): Expand documentation. + * sem_prag.adb (Analyze_Pragma): Remove warning about + CUDA_Device not being implemented. + +2021-10-04 Gary Dismukes <dismukes@adacore.com> + + * sem_ch7.adb (Analyze_Package_Specification): For types marked + as Must_Have_Preelab_Init, we now check for the presence of a + Preelaborable_Initialization aspect on the type, and pass the + aspect's expression (if any) on the call to + Has_Preelaborable_Initialization (or pass Empty if the type has + no such aspect or the aspect has no associated expression). + * sem_util.ads (Has_Preelaborable_Initialization): Change + Boolean formal parameter Formal_Types_Have_Preelab_Init to + instead be a formal of type Node_Id (named Preelab_Init_Expr), + to allow passing an expression that may be a conjunction of + Preelaborable_Initialization aspects. Revise spec comment + accordingly (and remove ??? comment). + * sem_util.adb (Type_Named_In_Preelab_Init_Expression): New + nested function with a result indicating whether a given type is + named as the prefix of a Preelaborable_Initialization attribute + in the expression of a corresponding P_I aspect. + (Has_Preelaborable_Initialization): For generic formal derived + and private types, test whether the type is named in the + expression Preelab_Init_Expr (by calling + Type_Named_In_Preelab_Init_Expression), and if so, treat the + formal type as having preelaborable initialization (returning + True). + * libgnat/a-cobove.ads (Vector): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as Element_Type'Preelaborable_Initialization. + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + * libgnat/a-cbdlli.ads (List): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as Element_Type'Preelaborable_Initialization. + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + * libgnat/a-cbhama.ads (Map): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as (Element_Type'Preelaborable_Initialization and + Key_Type'Preelaborable_Initialization). + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + * libgnat/a-cborma.ads (Map): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as (Element_Type'Preelaborable_Initialization and + Key_Type'Preelaborable_Initialization). + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + * libgnat/a-cbhase.ads (Set): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as Element_Type'Preelaborable_Initialization. + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + * libgnat/a-cborse.ads (Set): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as Element_Type'Preelaborable_Initialization. + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + * libgnat/a-cbmutr.ads (Tree): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as Element_Type'Preelaborable_Initialization. + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + * libgnat/a-coboho.ads (Holder): Replace pragma + Preelaborable_Initialization with the aspect, specifying its + value as Element_Type'Preelaborable_Initialization. + (Cursor): Replace pragma P_I with the aspect (defaulting to + True). + +2021-10-04 Yannick Moy <moy@adacore.com> + + * libgnat/a-textio.adb: Mark body out of SPARK. + * libgnat/a-textio.ads: Mark spec in SPARK and private part out + of SPARK. + * sem.adb (Semantics.Do_Analyze): Similar to ghost code + attributes, save and restore value of + Ignore_SPARK_Mode_Pragmas_In_Instance. + +2021-10-04 Bob Duff <duff@adacore.com> + + * libgnat/s-regpat.ads: Change Data_First to Data'First. Change + "still" to "always". Similar changes for Data_Last. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * sprint.adb (Sprint_Node_Actual): Refactor code for generic + package and subprogram declarations. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Indexed_Component, Resolve_Slice): Rename + the local constant Name to Pref; remove repeated calls to + Prefix. + +2021-10-04 Matthieu Eyraud <eyraud@adacore.com> + + * scos.ads: Extend the documentation. + * par_sco.adb (Process_Decisions): Emit specific SCOs for + quantified expressions. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Selected_Range_Checks): Fix style. + * exp_ch4.adb (Expand_N_Slice): Fix style and comment. + * sem_res.adb (Resolve_Indexed_Component): Fix style. + +2021-10-04 Yannick Moy <moy@adacore.com> + + * libgnat/a-strbou.ads: Add comments. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_attr.adb (Eval_Attribute): Evaluation of attribute + Leading_Part with illegal second parameter is now similar to + evaluation of Remainder with its second parameter being zero. + +2021-10-04 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Declare_Expression): Use tree traversals + to perform name capture of local entities in the expression of + the construct. + * exp_util.adb (Possible_Side_Effects_In_SPARK): Do not apply to + the prefix of an attribute reference Reduce when that prefix is + an aggregate, because it will be expanded into a loop, and has + no identifiable type. + +2021-10-04 Javier Miranda <miranda@adacore.com> + + * sem_ch8.adb (Build_Class_Wide_Wrapper): Fix handling of + class-wide subtypes; required to handle chains of + instantiations. Adding also code to identify these wrappers and + properly resolve instantiations where the wrapper and a tagged + type primitive are visible. + * einfo.ads (Is_Class_Wide_Wrapper): Adding documentation. + * gen_il-fields.ads (Opt_Field_Enum): Adding + Is_Class_Wide_Wrapper. + * gen_il-gen-gen_entities.adb (Root_Entity_Type): Adding + semantic flag Is_Class_Wide_Wrapper. + +2021-10-04 Bob Duff <duff@adacore.com> + + * einfo.ads (Declaration_Node): Document that Declaration_Node + for Itypes. + * einfo-utils.adb (Declaration_Node): Make it return Empty for + Itypes, or a proper type or subtype declaration. + * gen_il-gen.adb: Minor comment improvement. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Slice): Fix application of range checks + to slice range given as a subtype name. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Slice): Handle range given as a subtype + indication. + +2021-10-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_res.adb (Resolve_Slice): Add custom handling of attribute + Image and similar in CodePeer mode. This complements the + existing custom handling of these attributes in + Expand_N_Attribute_Reference. + +2021-10-04 Justin Squirek <squirek@adacore.com> + + * sem_util.adb (Is_Variable): Add check for implicitly + dereferenced access types + (Is_Dependent_Component_Of_Mutable_Object): Set Prefix_Type when + not specified. + +2021-10-04 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/the_gnat_compilation_model.rst (Binding generation): + Document specific behavior for /include/-ending paths and update. + * gnat_ugn.texi: Regenerate. + +2021-10-04 Arnaud Charlet <charlet@adacore.com> + + PR ada/102073 + * socket.c (__gnat_gethostbyaddr, __gnat_inet_pton): Add missing + return statements. + +2021-10-04 Justin Squirek <squirek@adacore.com> + + * sem_util.adb (Function_Or_Allocator_Level): Properly handle + direct function calls in the default alternative accessibility + checking mode. + +2021-10-04 Javier Miranda <miranda@adacore.com> + + * sem_util.adb (Is_Library_Level_Entity): Return False for + entities defined in E_Loop scopes. This change is not required + by the frontend; it is required by tools that depend on the + frontend sources. + * einfo-utils.adb (Is_Dynamic_Scope): Code cleanup. + +2021-10-04 Justin Squirek <squirek@adacore.com> + + * sem_util.adb (Accessibility_Level): Add a case to handle + renamed subprograms in addition to renamed objects. + +2021-10-04 Doug Rupp <rupp@adacore.com> + + * libgnarl/s-osinte__vxworks.ads (tlsKeyCreate): Return int. + * libgnarl/s-tpopsp__vxworks-rtp.adb (ERROR): Declare from + System.VxWorks.Ext.ERROR. + (Initialize): Declare IERR. Assert it. + * libgnarl/s-tpopsp__vxworks.adb (ERROR): Declare from + System.VxWorks.Ext.ERROR. + (Is_Valid_Task): Declare IERR. Test return. + * libgnarl/s-vxwext__kernel.adb (semDelete): Return STATUS. + +2021-10-04 Eric Botcazou <ebotcazou@adacore.com> + + * exp_disp.adb (Make_DT): Copy the Needs_Debug_Info flag from the + type onto the TSD object. + +2021-10-04 Steve Baird <baird@adacore.com> + + * sem_util.adb (Is_Repeatedly_Evaluated): Handle the case of an + Old attribute reference that occurs within what was originally a + quantified expression but which expansion has transformed into + an Expression_With_Actions. + +2021-10-04 Steve Baird <baird@adacore.com> + + * exp_ch4.adb (Expand_N_Indexed_Component): The two improvements + described above. + +2021-10-01 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Expand_Call_Helper): Do not call + Check_Subprogram_Variant if the subprogram is an ignored ghost + entity. Otherwise the compiler crashes (in debug builds) or + gives strange error messages (in production builds). + +2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com> + + * gnat_cuda.adb (Empty_CUDA_Global_Subprograms): New procedure. + (Expand_CUDA_Package): Call Empty_CUDA_Global_Subprograms. + +2021-10-01 Steve Baird <baird@adacore.com> + + * checks.ads: Define a type Dimension_Set. Add an out-mode + parameter of this new type to Generate_Index_Checks so that + callers can know for which dimensions a check was generated. Add + an in-mode parameter of this new type to + Apply_Subscript_Validity_Checks so that callers can indicate + that no check is needed for certain dimensions. + * checks.adb (Generate_Index_Checks): Implement new + Checks_Generated parameter. + (Apply_Subscript_Validity_Checks): Implement new No_Check_Needed + parameter. + * exp_ch4.adb (Expand_N_Indexed_Component): Call + Apply_Subscript_Validity_Checks in more cases than before. This + includes declaring two new local functions, + (Is_Renamed_Variable_Name, + Type_Requires_Subscript_Validity_Checks_For_Reads): To help in + deciding whether to call Apply_Subscript_Validity_Checks. + Adjust to parameter profile changes in Generate_Index_Checks and + Apply_Subscript_Validity_Checks. + +2021-10-01 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_characteristics.rst: Document + the rounding mode assumed for dynamic computations as per 3.5.7(16). + * gnat_rm.texi: Regenerate. + +2021-10-01 Bob Duff <duff@adacore.com> + + * table.ads (Table_Type): Remove "aliased"; no longer needed by + Atree. Besides it contradicted the comment a few lines above, + "-- Note: We do not make the table components aliased...". + * types.ads: Move type Slot to Atree. + * atree.ads: Move type Slot fromt Types to here. Move type + Node_Header from Seinfo to here. + * atree.adb: Avoid the need for aliased components of the Slots + table. Instead of 'Access, use a getter and setter. Misc + cleanups. + (Print_Statistics): Print statistics about node and entity kind + frequencies. Give 3 digit fractions instead of percentages. + * (Get_Original_Node_Count, Set_Original_Node_Count): Statistics + for calls to Original_Node and Set_Original_Node. + (Original_Node, Set_Original_Node): Gather statistics by calling + the above. + (Print_Field_Statistics): Print Original_Node statistics. + (Update_Kind_Statistics): Remove, and put all statistics + gathering under "if Atree_Statistics_Enabled", which is a flag + generated in Seinfo by Gen_IL. + * gen_il-gen.adb (Compute_Field_Offsets): Choose offsets of + Nkind, Ekind, and Homonym first. This causes a slight efficiency + improvement. Misc cleanups. Do not generate Node_Header; it is + now hand-written in Atree. When choosing the order in which to + assign offsets, weight by the frequency of the node type, so the + more common nodes get their field offsets assigned earlier. Add + more special cases. + (Compute_Type_Sizes): Remove this and related things. + There was a comment: "At some point we can instrument Atree to + print out accurate size statistics, and remove this code." We + have Atree statistics, so we now remove this code. + (Put_Seinfo): Generate Atree_Statistics_Enabled, which is equal + to Statistics_Enabled. This allows Atree to say "if + Atree_Statistics_Enabled then <gather statistics>" for + efficiency. When Atree_Statistics_Enabled is False, the "if ..." + will be optimized away. + * gen_il-internals.ads (Type_Frequency): New table of kind + frequencies. + * gen_il-internals.adb: Minor comment improvement. + * gen_il-fields.ads: Remove unused subtypes. Suppress style + checks in the Type_Frequency table. If we regenerate this + table (see -gnatd.A) we don't want to have to fiddle with + casing. + * impunit.adb: Minor. + * sinfo-utils.adb: Minor. + * debug.adb: Minor comment improvement. + +2021-10-01 Eric Botcazou <ebotcazou@adacore.com> + + * sem_type.adb (Specific_Type): Check that the type is tagged + before calling Interface_Present_In_Ancestor on it. + +2021-10-01 Eric Botcazou <ebotcazou@adacore.com> + + * debug.adb (d.8): Document usage. + * fe.h (Debug_Flag_Dot_8): Declare. + +2021-10-01 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Enter_Name): Suppress hiding warning when in an + instance. + +2021-10-01 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case Type_Key): Attribute can + be applied to a formal type. + * sem_ch5.adb (Analyze_Case_Statement): If Extensions_Allowed is + not enabled, verify that the type of the expression is discrete. + +2021-10-01 Justin Squirek <squirek@adacore.com> + + * exp_dbug.adb (Debug_Renaming_Declaration): Add check for + Entity present for Ren to prevent looking at unanalyzed nodes + +2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com> + + * atree.adb (Print_Statistics): Help CodePeer see Total as + greater than zero. + * gen_il-gen.adb (One_Comp): Annotate Field_Table as Modified. + +2021-10-01 Richard Kenner <kenner@adacore.com> + + * gen_il-gen-gen_entities.adb (Evaluable_Kind, + Global_Name_Kind): Add. + * gen_il-types.ads (Evaluable_Kind, Global_Name_Kind): Likewise. + +2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com> + + * aspects.ads: Add CUDA_Device aspect. + * gnat_cuda.ads (Add_CUDA_Device_Entity): New subprogram. + * gnat_cuda.adb: + (Add_CUDA_Device_Entity): New subprogram. + (CUDA_Device_Entities_Table): New hashmap for CUDA_Device + entities. + (Get_CUDA_Device_Entities): New internal subprogram. + (Set_CUDA_Device_Entities): New internal subprogram. + * par-prag.adb (Prag): Handle pragma id Pragma_CUDA_Device. + * sem_prag.ads (Aspect_Specifying_Pragma): Mark CUDA_Device as + being both aspect and pragma. + * sem_prag.adb (Analyze_Pragma): Add CUDA_Device entities to + list of CUDA_Entities belonging to package N. + (Sig_Flags): Signal CUDA_Device entities as referenced. + * snames.ads-tmpl: Create CUDA_Device names and pragmas. + +2021-10-01 Gary Dismukes <dismukes@adacore.com> + + * exp_util.adb (Build_DIC_Procedure_Body): Remove inappropriate + Assert pragma. Remove unneeded and dead code related to derived + private types. + +2021-10-01 Richard Kenner <kenner@adacore.com> + + * gen_il-gen-gen_nodes.adb (N_Alternative, N_Is_Case_Choice): + Add. + (N_Is_Exception_Choice, N_Is_Range): Likewise. + * gen_il-types.ads: Add above names. + * gen_il-gen.adb (Put_Union_Membership): Write both declarations + and definitions of union functions. + +2021-10-01 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Expand_Array_Aggregate, + Two_Pass_Aggregate_Expansion): Increment index for element + insertion within the loop, only if upper bound has not been + reached. + +2021-10-01 Javier Miranda <miranda@adacore.com> + + * contracts.ads (Make_Class_Precondition_Subps): New subprogram. + (Merge_Class_Conditions): New subprogram. + (Process_Class_Conditions_At_Freeze_Point): New subprogram. + * contracts.adb (Check_Class_Condition): New subprogram. + (Set_Class_Condition): New subprogram. + (Analyze_Contracts): Remove code analyzing class-wide-clone + subprogram since it is no longer built. + (Process_Spec_Postconditions): Avoid processing twice seen + subprograms. + (Process_Preconditions): Simplify its functionality to + non-class-wide preconditions. + (Process_Preconditions_For): No action needed for wrappers and + helpers. + (Make_Class_Precondition_Subps): New subprogram. + (Process_Class_Conditions_At_Freeze_Point): New subprogram. + (Merge_Class_Conditions): New subprogram. + * exp_ch6.ads (Install_Class_Preconditions_Check): New + subprogram. + * exp_ch6.adb (Expand_Call_Helper): Install class-wide + preconditions check on dispatching primitives that have or + inherit class-wide preconditions. + (Freeze_Subprogram): Remove code for null procedures with + preconditions. + (Install_Class_Preconditions_Check): New subprogram. + * exp_util.ads (Build_Class_Wide_Expression): Lower the + complexity of this subprogram; out-mode formal Needs_Wrapper + since this functionality is now provided by a new subprogram. + (Get_Mapped_Entity): New subprogram. + (Map_Formals): New subprogram. + * exp_util.adb (Build_Class_Wide_Expression): Lower the + complexity of this subprogram. Its previous functionality is now + provided by subprograms Needs_Wrapper and Check_Class_Condition. + (Add_Parent_DICs): Map the overridden primitive to the + overriding one. + (Get_Mapped_Entity): New subprogram. + (Map_Formals): New subprogram. + (Update_Primitives_Mapping): Adding assertion. + * freeze.ads (Check_Inherited_Conditions): Subprogram made + public with added formal to support late overriding. + * freeze.adb (Check_Inherited_Conditions): New implementation; + builds the dispatch table wrapper required for class-wide + pre/postconditions; added support for late overriding. + (Needs_Wrapper): New subprogram. + * sem.ads (Inside_Class_Condition_Preanalysis): New global + variable. + * sem_disp.ads (Covered_Interface_Primitives): New subprogram. + * sem_disp.adb (Covered_Interface_Primitives): New subprogram. + (Check_Dispatching_Context): Skip checking context of + dispatching calls during preanalysis of class-wide conditions + since at that stage the expression is not installed yet on its + definite context. + (Check_Dispatching_Call): Skip checking 6.1.1(18.2/5) by + AI12-0412 on helpers and wrappers internally built for + supporting class-wide conditions; for late-overriding + subprograms call Check_Inherited_Conditions to build the + dispatch-table wrapper (if required). + (Propagate_Tag): Adding call to + Install_Class_Preconditions_Check. + * sem_util.ads (Build_Class_Wide_Clone_Body): Removed. + (Build_Class_Wide_Clone_Call): Removed. + (Build_Class_Wide_Clone_Decl): Removed. + (Class_Condition): New subprogram. + (Nearest_Class_Condition_Subprogram): New subprogram. + * sem_util.adb (Build_Class_Wide_Clone_Body): Removed. + (Build_Class_Wide_Clone_Call): Removed. + (Build_Class_Wide_Clone_Decl): Removed. + (Class_Condition): New subprogram. + (Nearest_Class_Condition_Subprogram): New subprogram. + (Eligible_For_Conditional_Evaluation): No need to evaluate + class-wide conditions during preanalysis since the expression is + not installed on its definite context. + * einfo.ads (Class_Wide_Clone): Removed. + (Class_Postconditions): New attribute. + (Class_Preconditions): New attribute. + (Class_Preconditions_Subprogram): New attribute. + (Dynamic_Call_Helper): New attribute. + (Ignored_Class_Postconditions): New attribute. + (Ignored_Class_Preconditions): New attribute. + (Indirect_Call_Wrapper): New attribute. + (Is_Dispatch_Table_Wrapper): New attribute. + (Static_Call_Helper): New attribute. + * exp_attr.adb (Expand_N_Attribute_Reference): When the prefix + is of an access-to-subprogram type that has class-wide + preconditions and an indirect-call wrapper of such subprogram is + available, replace the prefix by the wrapper. + * exp_ch3.adb (Build_Class_Condition_Subprograms): New + subprogram. + (Register_Dispatch_Table_Wrappers): New subprogram. + * exp_disp.adb (Build_Class_Wide_Check): Removed; class-wide + precondition checks now rely on internally built helpers. + * sem_ch13.adb (Analyze_Aspect_Specifications): Set initial + value of attributes Class_Preconditions, Class_Postconditions, + Ignored_Class_Preconditions and Ignored_Class_Postconditions. + These values are later updated with the full pre/postcondition + by Merge_Class_Conditions. + (Freeze_Entity_Checks): Call + Process_Class_Conditions_At_Freeze_Point. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Remove code + building the body of the class-wide clone subprogram since it is + no longer required. + (Install_Entity): Adding assertion. + * sem_prag.adb (Analyze_Pre_Post_Condition_In_Decl_Part): Remove + code building and analyzing the class-wide clone subprogram; no + longer required. + (Build_Pragma_Check_Equivalent): Adjust call to + Build_Class_Wide_Expression since the formal named Needs_Wrapper + has been removed. + * sem_attr.adb (Analyze_Attribute_Old_Result): Skip processing + these attributes during preanalysis of class-wide conditions + since at that stage the expression is not installed yet on its + definite context. + * sem_res.adb (Resolve_Actuals): Skip applying RM 3.9.2(9/1) and + SPARK RM 6.1.7(3) on actuals of internal helpers and wrappers + built to support class-wide preconditions. + * sem_ch5.adb (Process_Bounds): Do not generate a constant + declaration for the bounds when we are preanalyzing a class-wide + condition. + (Analyze_Loop_Parameter_Specification): Handle preanalysis of + quantified expression placed in the outermost expression of a + class-wide condition. + * ghost.adb (Check_Ghost_Context): No check required during + preanalysis of class-wide conditions. + * gen_il-fields.ads (Opt_Field_Enum): Adding + Class_Postconditions, Class_Preconditions, + Class_Preconditions_Subprogram, Dynamic_Call_Helper, + Ignored_Class_Postconditions, Ignored_Class_Preconditions, + Indirect_Call_Wrapper, Is_Dispatch_Table_Wrapper, + Static_Call_Helper. + * gen_il-gen-gen_entities.adb (Is_Dispatch_Table_Wrapper): + Adding semantic flag Is_Dispatch_Table_Wrapper; removing + semantic field Class_Wide_Clone; adding semantic fields for + Class_Postconditions, Class_Preconditions, + Class_Preconditions_Subprogram, Dynamic_Call_Helper, + Ignored_Class_Postconditions, Indirect_Call_Wrapper, + Ignored_Class_Preconditions, and Static_Call_Helper. + +2021-10-01 Piotr Trojanek <trojanek@adacore.com> + + * comperr.adb (Delete_SCIL_Files): Handle generic subprogram + declarations and renaming just like generic package declarations + and renamings, respectively; handle + N_Subprogram_Renaming_Declaration. + +2021-10-01 Steve Baird <baird@adacore.com> + + * bcheck.adb (Check_Versions): Add support for the case where + the .ali file contains both a primary and a secondary version + number, as in "GNAT Lib v22.20210809". + +2021-10-01 Steve Baird <baird@adacore.com> + + * sem_res.adb (Resolve): Two separate fixes. In the case where + Find_Aspect for a literal aspect returns the aspect for a + different (ancestor) type, call Corresponding_Primitive_Op to + get the right callee. In the case where a downward tagged type + conversion appears to be needed, generate a null extension + aggregate instead, as per Ada RM 3.4(27). + * sem_util.ads, sem_util.adb: Add new Corresponding_Primitive_Op + function. It maps a primitive op of a tagged type and a + descendant type of that tagged type to the corresponding + primitive op of the descendant type. The body of this function + was written by Javier Miranda. + +2021-10-01 Bob Duff <duff@adacore.com> + + * atree.adb: Gather and print statistics about frequency of + getter and setter calls. + * atree.ads (Print_Statistics): New procedure for printing + statistics. + * debug.adb: Document -gnatd.A switch. + * gen_il-gen.adb: Generate code for statistics gathering. + Choose the offset of Homonym early. Misc cleanup. Put more + comments in the generated code. + * gen_il-internals.ads (Unknown_Offset): New value to indicate + that the offset has not yet been chosen. + * gnat1drv.adb: Call Print_Statistics. + * libgnat/s-imglli.ads: Minor comment fix. + * output.ads (Write_Int_64): New procedure to write a 64-bit + value. Needed for new statistics, and could come in handy + elsewhere. + * output.adb (Write_Int_64): Likewise. + * sinfo.ads: Remove obsolete comment. The xtreeprs program no + longer exists. + * types.ads: New 64-bit types needed for new statistics. + +2021-10-01 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/memtrack.adb (Putc): New routine wrapped around fputc + with error check. + (Write): New routine wrapped around fwrite with error check. + Remove bound functions fopen, fwrite, fputs, fclose, OS_Exit. + Use the similar routines from System.CRTL and System.OS_Lib. + +2021-10-01 Ed Schonberg <schonberg@adacore.com> + + * exp_aggr.adb (Must_Slide): If the aggregate only contains an + others_clause no sliding id involved. Otherwise sliding is + required if any bound of the aggregate or the context subtype is + non-static. + +2021-10-01 Richard Kenner <kenner@adacore.com> + + * gen_il-gen-gen_nodes.adb (N_Is_Decl): Add. + * gen_il-types.ads (N_Is_Decl): Likewise. + +2021-10-01 Richard Kenner <kenner@adacore.com> + + * gen_il-gen-gen_nodes.adb (N_Entity_Name): Add. + * gen_il-types.ads (N_Entity_Name): Likewise. + +2021-10-01 Steve Baird <baird@adacore.com> + + * bcheck.adb (Check_Versions): In the case of an ali file + version mismatch, if distinct integer values can be extracted + from the two version strings then include those values in the + generated error message. + +2021-10-01 Steve Baird <baird@adacore.com> + + * sem_elab.adb (Is_Safe_Call): Return True in the case of a + (possibly rewritten) call to an expression function. + +2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_aggr.adb (Resolve_Iterated_Component_Association): + Initialize Id_Typ to Any_Type by default. + +2021-10-01 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/gnat_and_program_execution.rst (gnatmem): Document + that it works only with fixed-position executables. + +2021-10-01 Doug Rupp <rupp@adacore.com> + + * libgnat/s-parame__vxworks.ads (time_t_bits): Change to + Long_Long_Integer'Size. + +2021-09-23 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity): Fix comment. + +2021-09-23 Richard Kenner <kenner@adacore.com> + + * gen_il-gen-gen_entities.adb (Subprogram_Body_Or_Type): Add. + * gen_il-types.ads (Subprogram_Body_Or_Type): Likewise. + +2021-09-23 Richard Kenner <kenner@adacore.com> + + * einfo-utils.adb (Next_Index): Verify input and output are + N_Is_Index. + * gen_il-gen-gen_nodes.adb (N_Has_Bounds, N_Is_Index): Add. + * gen_il-types.ads (N_Has_Bounds, N_Is_Index): Likewise. + * sem_ch3.adb (Array_Type_Declaration): Use Next, not + Next_Index. + * sem_ch12.adb (Formal_Dimensions): Likewise. + * sem_util.adb (Is_Valid_Renaming): Likewise. + +2021-09-23 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst (gnatsymbolize): + Document new --load option and -g1 as minimal compilation + requirement. + +2021-09-23 Piotr Trojanek <trojanek@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Only keep the bounds + for internally generated attributes; otherwise, compute them + anew. + +2021-09-23 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Build_Access_Subprogram_Wrapper): Decorate the + wrapper with attribute Is_Wrapper, and move its declaration to + the freezing actions of its type declaration; done to facilitate + identifying it at later stages to avoid handling it as a + primitive operation of a tagged type; otherwise it may be + handled as a dispatching operation and erroneously registered in + a dispatch table. + (Make_Index): Add missing decoration of field Parent. + * sem_disp.adb (Check_Dispatching_Operation): Complete + decoration of late-overriding dispatching primitives. + (Is_Access_To_Subprogram_Wrapper): New subprogram. + (Inherited_Subprograms): Prevent cascaded errors; adding missing + support for private types. + * sem_type.adb (Add_One_Interp): Add missing support for the + first interpretation of a primitive of an inmediate ancestor + interface. + * sem_util.adb (Check_Result_And_Post_State_In_Pragma): Do not + report missing reference in postcondition placed in internally + built wrappers. + * exp_disp.adb (Expand_Dispatching_Call): Adding assertion. + +2021-09-23 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Resolve_Array_Aggregate): Check the validity of + an array aggregate all of whose components are iterated + component associations. + * exp_aggr.adb (Expand_Array_Aggregate, + Two_Pass_Aggregate_Expansion): implement two-pass algorithm and + replace original aggregate with resulting temporary, to ensure + that a proper length check is performed if context is + constrained. Use attributes Pos and Val to handle index types of + any discrete type. + +2021-09-23 Bob Duff <duff@adacore.com> + + * gen_il-gen.adb: Set the number of concrete nodes that have the + Homonym field to a higher number than any other field. This + isn't true, but it forces Homonym's offset to be chosen first, + so it will be at offset zero and hence slot zero. + +2021-09-23 Richard Kenner <kenner@adacore.com> + + * atree.adb (Relocate_Node): If relocating a subprgram call and + we're doing unnesting, make a new Parameter_Associations, if + any. + +2021-09-23 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/a-strbou.ads (Generic_Bounded_Length): Remove explicit + Initializes contract. + +2021-09-23 Bob Duff <duff@adacore.com> + + * gen_il-gen.adb: Generate getters and setters with much of the + code inlined. Generate code for storing a few fields in the node + header, to avoid the extra level of indirection for those + fields. We generate the header type, so we don't have to + duplicate hand-written Ada and C code to depend on the number of + header fields. Declare constants for slot size. Use short names + because these are used all over. Remove + Put_Low_Level_Accessor_Instantiations, Put_Low_Level_C_Getter, + which are no longer needed. Rename + Put_High_Level_C_Getter-->Put_C_Getter. + * atree.ads, atree.adb: Take into account the header slots. + Take into account the single Node_Or_Entity_Field type. Remove + "pragma Assertion_Policy (Ignore);", because the routines in + this package are no longer efficiency critical. + * atree.h: Remove low-level getters, which are no longer used by + sinfo.h and einfo.h. + * einfo-utils.adb: Avoid crash in Known_Alignment. + * live.adb, sem_eval.adb: Remove code that prevents Node_Id from + having a predicate. We don't actually add a predicate to + Node_Id, but we want to be able to for temporary debugging. + * sinfo-utils.adb: Remove code that prevents Node_Id from having + a predicate. Take into account the single Node_Or_Entity_Field + type. + * sinfo-utils.ads: Minor. + * table.ads (Table_Type): Make the components aliased, because + low-level setters in Atree need to take 'Access. + * treepr.adb: Take into account the single Node_Or_Entity_Field + type. Make some code more robust, so we can print out + half-baked nodes. + * types.ads: Move types here for visibility purposes. + * gcc-interface/gigi.h, gcc-interface/trans.c: Take into account + the Node_Header change in the GNAT front end. + * gcc-interface/cuintp.c, gcc-interface/targtyps.c: Add because + gigi.h now refers to type Node_Header, which is in sinfo.h. + +2021-09-23 Yannick Moy <moy@adacore.com> + + * libgnat/a-strfix.adb (Delete, Insert, Overwrite, + Replace_Slice): Remove SPARK_Mode Off. + * libgnat/a-strfix.ads (Insert, Overwrite, Replace_Slice): + Strengthen precondition. + +2021-09-23 Piotr Trojanek <trojanek@adacore.com> + + * libgnat/a-strbou.ads (Generic_Bounded_Length): Remove non-null + Global contracts. + +2021-09-23 Steve Baird <baird@adacore.com> + + * doc/gnat_rm/implementation_defined_characteristics.rst: Update + this section to reflect the current version of Ada RM M.2. + * gnat_rm.texi: Regenerate. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * libgnat/a-strfix.ads (Trim): Simplify contracts. + * libgnat/a-strfix.adb (Trim): Remove white space. + +2021-09-22 Piotr Trojanek <trojanek@adacore.com> + + * exp_ch4.adb (Expand_N_Op_Eq): Reuse Is_Attribute_Result. + * exp_prag.adb (Expand_Attributes): Reuse Is_Attribute_Old. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): Do not insert a + predicate check after a deferred constant declaration. + +2021-09-22 Bob Duff <duff@adacore.com> + + * contracts.adb, einfo-utils.adb, einfo-utils.ads, exp_ch7.adb, + exp_ch9.adb, exp_disp.adb, exp_prag.adb, exp_smem.adb, + exp_util.adb, freeze.adb, sem_aggr.adb, sem_attr.adb, + sem_ch8.adb, sem_prag.ads, sem_util.adb, sem_util.ads: Fix + conformance errors. + * errout.adb, erroutc.adb: Remove pragmas Suppress. + * err_vars.ads: Initialize variables that were previously being + read uninitialized. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * libgnat/a-strunb.ads: Mark package in SPARK with private part + not in SPARK. + (Free): Mark not in SPARK. + +2021-09-22 Arnaud Charlet <charlet@adacore.com> + + * snames.ads-tmpl: Update status of some attributes. + +2021-09-22 Doug Rupp <rupp@adacore.com> + + * libgnarl/s-interr__vxworks.adb (Interfaces.C): Remove as + unused. + (System.VxWorks.Ext): Import. + (System.VxWorks.Ext.STATUS): use type. + (STATUS): New subtype. + (OK): New constant. + (Interrupt_Connector): Return STATUS type vice int. + (Interrupt_Connect, Notify_Interrupt, Unbind_Handler, + Interrupt_Server_Task): Rename Status to Result. Assert Result = + OK. + * libgnarl/s-osinte__vxworks.adb (To_Clock_Ticks): Define constant + IERR, and return it vice ERROR. + (Binary_Semaphore_Delete): Return STATUS type vice int. + (Binary_Semaphore_Obtain): Likewise. + (Binary_Semaphore_Release): Likewise. + (Binary_Semaphore_Flush): Likewise. + * libgnarl/s-osinte__vxworks.ads (SVE): Renaming of + System.VxWorks.Ext. + (STATUS): Use SVE in declaration of subtype. + (BOOL): Likewise. + (vx_freq_t): Likewise. + (t_id): Likewise. + (gitpid): Use SVE in renaming of subprogram + (Task_Stop): Likewise. + (Task_Cont): Likewise. + (Int_Lock): Likewise. + (Int_Unlock): Likewise. + (Set_Time_Slice): Likewise. + (semDelete): Likewise. + (taskCpuAffinitySet): Likewise. + (taskMaskAffinitySet): Likewise. + (sigset_t): Use SVE in declaration of type. + (OK): Remove as unused. + (ERROR): Likewise. + (taskOptionsGet): return STATUS vice int. + (taskSuspend): Likewise. + (taskResume): Likewise. + (taskDelay): Likewise. + (taskVarAdd): Likewise. + (taskVarDelete): Likewise. + (taskVarSet): Likewise. + (tlkKeyCreate): Likewise. + (taskPrioritySet): Likewise. + (semGive): Likewise. + (semTake): Likewise. + (Binary_Semaphore_Delete): Likewise. + (Binary_Semaphore_Obtain): Likewise. + (Binary_Semaphore_Release): Likewise. + (Binary_Semaphore_Flush): Likewise. + (Interrupt_Connect): Likewise. + * libgnarl/s-taprop__vxworks.adb + (System.VxWorks.Ext.STATUS): use type. + (int): Syntactically align subtype. + (STATUS): New subtype. + (OK): New constant. + (Finalize_Lock): Check STATUS vice int. Assert OK. + (Finalize_Lock): Likewise. + (Write_Lock): Likewise. + (Write_Lock): Likewise. + (Write_Lock): Likewise. + (Unlock): Likewise. + (Unlock): Likewise. + (Unlock): Likewise. + (Unlock): Likewise. + (Sleep): Likewise. + (Sleep): Likewise. + (Sleep): Likewise. + (Timed_Sleep): Likewise and test Result. + (Timed_Delay): Likewise and test Result. + (Wakeup): Likewise. + (Yield): Likewise. + (Finalize_TCB): Likewise. + (Suspend_Until_True): Check OK. + (Stop_All_Tasks): Declare Dummy STATUS vice in. Check OK. + (Is_Task_Context): Use OSI renaming. + (Initialize): Use STATUS vice int. + * libgnarl/s-vxwext.adb + (IERR): Renamed from ERROR. + (taskCpuAffinitySet): Return IERR (int). + (taskMaskAffinitySet): Likewise. + * libgnarl/s-vxwext.ads + (STATUS): New subtype. + (OK): New STATUS constant. + (ERROR): Likewise. + * libgnarl/s-vxwext__kernel-smp.adb + (IERR): Renamed from ERROR. + (Int_Lock): Return IERR. + (semDelete): Return STATUS. + (Task_Cont): Likewise. + (Task_Stop): Likewise. + * libgnarl/s-vxwext__kernel.adb + (IERR): Renamed from ERROR. + (semDelete): Return STATUS. + (Task_Cont): Likewise. + (Task_Stop): Likewise. + (taskCpuAffinitySet): Return IERR (int) + (taskMaskAffinitySet): Likewise. + * libgnarl/s-vxwext__kernel.ads + (STATUS): New subtype. + (OK): New STATUS constant. + (ERROR): Likewise. + (Interrupt_Connect): Return STATUS + (semDelete): Likewise. + (Task_Cont): Likewise. + (Task_Stop): Likewise. + (Set_Time_Slice): Likewise. + * libgnarl/s-vxwext__rtp-smp.adb + (IERR): Renamed from ERROR. + (Int_Lock): return IERR constant vice ERROR. + (Interrupt_Connect): Return STATUS. + (semDelete): Likewise. + (Set_Time_Slice): Likewise. + * libgnarl/s-vxwext__rtp.adb + (IERR): Renamed from ERROR. + (Int_Lock): return IERR constant vice ERROR. + (Int_Unlock): Return STATUS. + (semDelete): Likewise. + (Set_Time_Slice): Likewise. + (taskCpuAffinitySet): Return IERR (int) + (taskMaskAffinitySet): Likewise. + * libgnarl/s-vxwext__rtp.ads + (STATUS): New subtype. + (OK): New STATUS constant. + (ERROR): Likewise. + (Interrupt_Connect): Return STATUS + (semDelete): Likewise. + (Task_Cont): Likewise. + (Task_Stop): Likewise. + (Set_Time_Slice): Likewise. + +2021-09-22 Arnaud Charlet <charlet@adacore.com> + + * prep.adb (Preprocess): Allow for more flexibility when + Relaxed_RM_Semantics is set. + +2021-09-22 Pierre-Alexandre Bazin <bazin@adacore.com> + + * libgnat/a-strbou.adb: Turn SPARK_Mode on. + * libgnat/a-strbou.ads: Write contracts. + * libgnat/a-strfix.ads (Index): Fix grammar error in a comment. + * libgnat/a-strsea.ads (Index): Likewise. + * libgnat/a-strsup.adb: Rewrite the body to take into account + the new definition of Super_String using Relaxed_Initialization + and a predicate. + (Super_Replicate, Super_Translate, Times): Added loop + invariants, and ghost lemmas for Super_Replicate and Times. + (Super_Trim): Rewrite the body using search functions to + determine the cutting points. + (Super_Element, Super_Length, Super_Slice, Super_To_String): + Remove (now written as expression functions in a-strsup.ads). + * libgnat/a-strsup.ads: Added contracts. + (Super_Element, Super_Length, Super_Slice, Super_To_String): + Rewrite as expression functions. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): Add guard. + +2021-09-22 Doug Rupp <rupp@adacore.com> + + * libgnarl/s-vxwext.ads (BOOL): New int type. + (Interrupt_Context): Change return type to BOOL. + * libgnarl/s-vxwext__kernel.ads: Likewise. + * libgnarl/s-vxwext__rtp-smp.adb: Likewise. + * libgnarl/s-vxwext__rtp.adb: Likewise. + * libgnarl/s-vxwext__rtp.ads: Likewise. + * libgnarl/s-osinte__vxworks.adb (Interrupt_Context): Change + return type to BOOL. + * libgnarl/s-osinte__vxworks.ads (BOOL) New subtype. + (taskIsSuspended): Change return type to BOOL. + (Interrupt_Context): Change return type to BOOL. Adjust comments + accordingly. + * libgnarl/s-taprop__vxworks.adb (System.VxWorks.Ext.BOOL): + use type. + (Is_Task_Context): Test Interrupt_Context against 0. + * libgnat/i-vxwork.ads (BOOL): New int. + (intContext): Change return type to BOOL. Adjust comments. + * libgnat/i-vxwork__x86.ads: Likewise. + +2021-09-22 Piotr Trojanek <trojanek@adacore.com> + + * sem_aux.adb, sem_aux.ads (Package_Body): Moved from GNATprove. + * sem_elab.adb (Spec_And_Body_From_Entity): Refine type of parameter. + +2021-09-22 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/platform_specific_information.rst: Improve doc + on permission and containers. + * gnat_ugn.texi: Regenerate. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * atree.adb (Rewrite): Fix parent node of shared aspects. + * atree.ads (Rewrite): Add ??? comment on incorrect + documentation. + * einfo-utils.adb (Known_Esize): Fix logic. + * sem_ch13.adb (Alignment_Check_For_Size_Change, + Analyze_Attribute_Definition_Clause): Protect against unset + Size. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * freeze.adb (Build_Renamed_Body): Special case for GNATprove. + * sem_ch6.adb (Analyze_Expression_Function): Remove useless test + for a node to come from source, which becomes harmful otherwise. + +2021-09-22 Justin Squirek <squirek@adacore.com> + + * ali.adb, ali.ads (Scan_ALI): Remove use of deprecated + parameter Ignore_ED, and all specification for Lower in call to + Get_File_Name. + * ali-util.adb (Read_Withed_ALIs): Modify call to Scan_ALI. + * clean.adb (Clean_Executables): Likewise. + * gnatbind.adb (Add_Artificial_ALI_File, Executable section): + Likewise. + * gnatlink.adb (Executable section): Likewise. + * gnatls.adb (Executable section): Likewise. + * make.adb (Check, Wait_For_Available_Slot): Likewise. + * aspects.ads: Add Aspect_No_Controlled_Parts to + Nonoverridable_Aspect_Id + * opt.ads: Remove function pointers used as a workaround for + ASIS. + * osint-c.adb (Executable section): Remove setting of function + pointer workarounds needed for ASIS. + * osint.adb (Read_Default_Search_Dirs): Correct behavior to + detect EOL characters. + * par_sco.adb (Output_Header): Remove comment regarding use of + First_Sloc. + (Traverse_Sync_Definition): Renamed to + Traverse_Protected_Or_Task_Definition. + * pprint.adb (Interal_List_Name): Add description about purpose, + and refactor conditional statement. + (Prepend): Removed. + * repinfo.adb (List_Rep_Info, Write_Info_Line): Remove use of + subprogram pointer. + * scng.adb (Scan): Remove CODEFIX question, and minor comment + change. + * sem_attr.adb (Analyze_Image_Attribute): Remove special + processing for 'Img. + * sem_ch6.adb (Check_Untagged_Equality): Add RM reference. + (FCE): Add comment describing behavior. + (Is_Non_Overriding_Operation): Minor comment formatting change. + * sem_type.adb (Is_Actual_Subprogram): Add comment about + Comes_From_Source test. + (Matching_Types): Describe non-matching cases. + * sem_util.adb (Is_Confirming): Add stub case for + No_Controlled_Parts. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): Access + Predicated_Parent only on subtypes. + +2021-09-22 Arnaud Charlet <charlet@adacore.com> + + * sem_prag.adb (Process_Import_Or_Interface): Relax error when + Relaxed_RM_Semantics. + +2021-09-22 Steve Baird <baird@adacore.com> + + * libgnat/s-regpat.adb (Match): Handle the case where Self.First + is not NUL (so we know the first character we are looking for), + but case-insensitive matching has + been specified. + (Optimize): In the case of an EXACTF Op, set Self.First as is + done in the EXACT case, except with the addition of a call to + Lower_Case. + +2021-09-22 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-imenne.ads, libgnat/s-imenne.adb: Delete. + * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Remove s-imenne.o. + (GNATBIND_OBJS): Likewise. + +2021-09-22 Yannick Moy <moy@adacore.com> + + * einfo.ads: Fix comments. + * exp_aggr.adb: Fix variable name. + * exp_util.adb: Fix comments. + * sem_ch13.adb: Fix comments. + * sem_ch3.adb: Fix comments and variable name. + +2021-09-22 Doug Rupp <rupp@adacore.com> + + * libgnarl/s-osinte__vxworks.ads: Make procedure vice function. + * libgnarl/s-vxwext.ads: Likewise. + * libgnarl/s-vxwext__kernel-smp.adb: Likewise. + * libgnarl/s-vxwext__kernel.adb: Likewise. + * libgnarl/s-vxwext__kernel.ads: Likewise. + * libgnarl/s-vxwext__rtp-smp.adb: Likewise. + * libgnarl/s-vxwext__rtp.adb: Likewise. + * libgnarl/s-vxwext__rtp.ads: Likewise. + * libgnarl/s-taprop__vxworks.adb (Stop_All_Tasks): Call + Int_Unlock as a procedure. + +2021-09-22 Doug Rupp <rupp@adacore.com> + + * libgnarl/s-osinte__vxworks.ads (SVE): New package renaming + (vx_freq_t): New subtype. + (sysClkRateGet): Return vx_freq_t. + * libgnarl/s-vxwext.ads (vx_freq_t): New type. + * libgnarl/s-vxwext__kernel.ads: Likewise. + * libgnarl/s-vxwext__rtp.ads: Likewise. + +2021-09-22 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_case.adb (Composite_Case_Ops): Replace 'Image with + Error_Msg_Uint. + +2021-09-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_If_Expression): Generate an intermediate + temporary when the expression is a condition in an outer decision + and control-flow optimizations are suppressed. + +2021-09-22 Steve Baird <baird@adacore.com> + + * exp_ch5.adb (Expand_General_Case_Statement.Pattern_Match): Add + new function Indexed_Element to handle array element + comparisons. Handle case choices that are array aggregates, + string literals, or names denoting constants. + * sem_case.adb (Composite_Case_Ops.Array_Case_Ops): New package + providing utilities needed for casing on arrays. + (Composite_Case_Ops.Choice_Analysis): If necessary, include + array length as a "component" (like a discriminant) when + traversing components. We do not (yet) partition choice analysis + to deal with unequal length choices separately. Instead, we + embed everything in the minimum-dimensionality Cartesian product + space needed to handle all choices properly; this is determined + by the length of the longest choice pattern. + (Composite_Case_Ops.Choice_Analysis.Traverse_Discrete_Parts): + Include length as a "component" in the traversal if necessary. + (Composite_Case_Ops.Choice_Analysis.Parse_Choice.Traverse_Choice): + Add support for case choices that are string literals or names + denoting constants. + (Composite_Case_Ops.Choice_Analysis): Include length as a + "component" in the analysis if necessary. + (Check_Choices.Check_Case_Pattern_Choices.Ops.Value_Sets.Value_Index_Count): + Improve error message when capacity exceeded. + * doc/gnat_rm/implementation_defined_pragmas.rst: Update + documentation to reflect current implementation status. + * gnat_rm.texi: Regenerate. + +2021-09-22 Eric Botcazou <ebotcazou@adacore.com> + + * freeze.adb (Check_Component_Storage_Order): Give a specific error + message for non-byte-aligned component in the packed case. Replace + "composite" with "record" in both cases. + +2021-09-22 Arnaud Charlet <charlet@adacore.com> + + * libgnarl/a-tasini.ads, libgnarl/a-tasini.adb: Make compatible + with No_Elaboration_Code_All. + * libgnarl/s-taskin.ads, libgnarl/s-tassta.adb: Adjust + accordingly. + +2021-09-22 Arnaud Charlet <charlet@adacore.com> + + * sem_ch6.adb (Check_Returns): Change message on missing return. + +2021-09-22 Arnaud Charlet <charlet@adacore.com> + + * gnatfind.adb, gnatxref.adb: Mark these tools as obsolete + before removing them completely. + +2021-09-22 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (range_cannot_be_superflat): Tweak comments. + +2021-09-21 Doug Rupp <rupp@adacore.com> + + * init.c (__gnat_error_handler) [LynxOS]: Add a comment about + missing optional args. + +2021-09-21 Yannick Moy <moy@adacore.com> + + * gen_il-gen.adb (Put_Opt_Subtype): Add suffix. + +2021-09-21 Justin Squirek <squirek@adacore.com> + + * sem_util.adb (Accessibility_Level): Remove spurious special + case for protected type components. + * exp_ch4.adb (Generate_Accessibility_Check): Use general + Accessibility_Level instead of the low-level function + Type_Access_Level. + +2021-09-21 Eric Botcazou <ebotcazou@adacore.com> + + * gnat_ugn.texi: Regenerate. + +2021-09-21 Matthieu Eyraud <eyraud@adacore.com> + + * par_sco.adb (Traverse_One): Add support for pragma Invariant / + Type_Invariant. + +2021-09-21 Bob Duff <duff@adacore.com> + + * gen_il-gen.adb (Put_Opt_Subtype): Print out subtypes of the + form: + subtype Opt_N_Declaration is + Node_Id with Predicate => + Opt_N_Declaration = Empty or else + Opt_N_Declaration in N_Declaration_Id; + One for each node or entity type, with the predicate allowing + Empty. + * atree.adb (Parent, Set_Parent): Remove unnecessary "Atree.". + +2021-09-21 Patrick Bernardi <bernardi@adacore.com> + + * bindgen.adb (Gen_Adainit): For targets that suppress the + standard library: set the default stack size global variable if + a value is provided via the -d switch, and generate a call to + __gnat_initialize_stack_limit if stack checking using stack + limits is enabled. + +2021-09-21 Bob Duff <duff@adacore.com> + + * sem_ch13.adb (Stream_Size): Print message about allowed stream + sizes even if other error were already found. This avoids + falling into the 'else', which prints "Stream_Size cannot be + given for...", which is misleading -- the Size COULD be given if + it were correct. + +2021-09-21 Daniel Mercier <mercier@adacore.com> + + * exp_util.adb (Build_Temporary): In case of an external DISCR + symbol, set the related expression for CodePeer so that a more + comprehensible message can be emitted to the user. + +2021-09-21 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-dwalin.adb (Parse_Header): Tweak comments. + (Read_Entry_Format_Array): Tweak exception message. + (Symbolic_Address.Set_Result): Likewise. + +2021-09-21 Ed Schonberg <schonberg@adacore.com> + + * exp_ch7.adb (Make_Init_Call): Add guard to protect against a + missing initialization procedure for a type. + +2021-09-21 Doug Rupp <rupp@adacore.com> + + * Makefile.rtl: Remove unused VxWorks sections. + * libgnarl/s-vxwext__noints.adb: Remove. + * libgnarl/s-vxwext__vthreads.ads: Remove. + * libgnat/a-elchha__vxworks-ppc-full.adb: Remove. + * libgnat/s-osprim__vxworks.adb: Remove. + * libgnat/s-osvers__vxworks-653.ads: Remove. + * libgnat/system-vxworks-e500-vthread.ads: Remove. + * libgnat/system-vxworks-ppc-vthread.ads: Remove. + * libgnat/system-vxworks-x86-vthread.ads: Remove. + +2021-09-21 Bob Duff <duff@adacore.com> + + * uintp.ads, uintp.adb (UI_Is_In_Int_Range): Change the type of + the formal parameter to Valid_Uint. Remove code that preserved + the previous behavior, and replace it with an assertion. The + previous behavior is no longer needed given the recent change to + gigi. + (No, Present): Add comment. + +2021-09-21 Bob Duff <duff@adacore.com> + + * sem_eval.adb (Fold_Shift): Replace an if_expression with an + if_statement. + +2021-09-21 Bob Duff <duff@adacore.com> + + * uintp.ads, uintp.adb: Add assertions. + (Ubool, Opt_Ubool): New "boolean" subtypes. + (UI_Is_In_Int_Range): The parameter should probably be + Valid_Uint, but we don't change that for now, because it causes + failures in gigi. + * sem_util.ads, sem_util.adb (Is_True, Is_False, + Static_Boolean): Use Opt_Ubool subtype. Document the fact that + Is_True (No_Uint) = True. Implement Is_False in terms of + Is_True. We considered changing Static_Boolean to return Uint_1 + in case of error, but that doesn't fit in well with + Static_Integer. + (Has_Compatible_Alignment_Internal): Deal with cases where Offs + is No_Uint. Change one "and" to "and then" to ensure we don't + pass No_Uint to ">", which would violate the new assertions. + * exp_util.adb, freeze.adb, sem_ch13.adb: Avoid violating new + assertions in Uintp. + +2021-09-21 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-dwalin.adb (To_File_Name): Fetch only the last string + from the .debug_line_str section. + (Symbolic_Address.Set_Result): Likewise. + +2021-09-21 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-dwalin.adb (Skip_Form): Fix cases of DW_FORM_addrx + and DW_FORM_implicit_const. Replace Constraint_Error with + Dwarf_Error. + +2021-09-21 Ghjuvan Lacambre <lacambre@adacore.com> + + * exp_pakd.adb (Expand_Packed_Not): Replace expression with + statement. + +2021-09-21 Ghjuvan Lacambre <lacambre@adacore.com> + + * sem_eval.adb (Is_Static_Subtype): Take predicates created + through "predicate" pragma into account. + +2021-09-21 Frederic Konrad <konrad@adacore.com> + + * Makefile.rtl (aarch64-rtems*): Add GNATRTL_128BIT_PAIRS to + the LIBGNAT_TARGET_PAIRS list and also GNATRTL_128BIT_OBJS to + the EXTRA_GNATRTL_NONTASKING_OBJS list. + +2021-09-21 Gary Dismukes <dismukes@adacore.com> + + * sem_ch4.adb (Remove_Abstract_Operations): Add condition to + test for an E_Operator as part of criteria for setting + Abstract_Op on interpretations involving predefined operators. + +2021-09-21 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): For explicit + dereference of type conversion, enable code that ensures that + the tag of the result is that of the result type. + +2021-09-21 Bob Duff <duff@adacore.com> + + * einfo-utils.adb: Add support (currently disabled) for using + "initial zero" instead of "Uint_0" to represent "unknown". Call + Known_ functions, instead of evilly duplicating their code + inline. + * fe.h (No_Uint_To_0): New function to convert No_Uint to + Uint_0, in order to preserve existing behavior. + (Copy_Esize, Copy_RM_Size): New imports from Einfo.Utils. + * cstand.adb: Set size fields of Standard_Debug_Renaming_Type + and Standard_Exception_Type. + * checks.adb, exp_attr.adb, exp_ch3.adb, exp_ch5.adb, + exp_ch6.adb, exp_pakd.adb, exp_util.adb, freeze.adb, itypes.adb, + layout.adb, repinfo.adb, sem_attr.adb, sem_ch12.adb, + sem_ch13.adb, sem_ch13.ads, sem_ch3.adb, sem_ch7.adb, + sem_util.adb: Protect calls with Known_..., use Copy_... Remove + assumption that Uint_0 represents "unknown". + * types.ads (Nonzero_Int): New subtype. + * gcc-interface/decl.c, gcc-interface/trans.c: Protect calls + with Known_... and use Copy_... as appropriate, to avoid + blowing up in unknown cases. Similarly, call No_Uint_To_0 to + preserve existing behavior. + +2021-09-21 Steve Baird <baird@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Add a new nested + function, Directly_Specified, and then use it in the + implementation of the required check. + +2021-09-21 Steve Baird <baird@adacore.com> + + * libgnat/a-costso.ads, libgnat/a-costso.adb: A new library + unit, Ada.Containers.Stable_Sorting, which exports a pair of + generics (one within the other) which are instantiated by each + of the 5 doubly-linked list container generics to implement + their respective Sort procedures. We use a pair of generics, + rather than a single generic, in order to further reduce code + duplication. The outer generic takes a formal private Node_Ref + type representing a reference to a linked list element. For some + instances, the corresponding actual parameter will be an access + type; for others, it will be the index type for an array. + * Makefile.rtl: Include new Ada.Containers.Stable_Sorting unit. + * libgnat/a-cbdlli.adb, libgnat/a-cdlili.adb, + libgnat/a-cfdlli.adb, libgnat/a-cidlli.adb, libgnat/a-crdlli.adb + (Sort): Replace existing Sort implementation with a call to an + instance of + Ada.Containers.Stable_Sorting.Doubly_Linked_List_Sort. Declare + the (trivial) actual parameters needed to declare that instance. + * libgnat/a-cfdlli.ads: Fix a bug encountered during testing in + the postcondition for M_Elements_Sorted. With a partial + ordering, it is possible for all three of (X < Y), (Y < X), + and (X = Y) to be simultaneously false, so that case needs to + handled correctly. + +2021-09-21 Piotr Trojanek <trojanek@adacore.com> + + * errout.adb (Error_Msg_Internal): Fix references to Sptr and + Optr in comment; fix grammar of "low-level" where it is used as + an adjective. + +2021-09-21 Piotr Trojanek <trojanek@adacore.com> + + * errout.adb (Write_Source_Code_Lines): Use Cur_Loc before + incrementing it, so that we don't need to decrement it. + +2021-09-21 Yannick Moy <moy@adacore.com> + + * errout.adb (Get_Line_End): Do not allow the result to go past + the end of the buffer. + +2021-09-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Process_Discriminant_Expressions): If the + constraint is for a Component_Definition that appears in a + Component_Declaration, the entity to be used to create the + potentially global symbol is the Defining_Identifier of the + Component_Declaration. + +2021-09-21 Bob Duff <duff@adacore.com> + + * libgnat/a-stbufi.ads, libgnat/a-stbufi.adb: Change all + occurrences of GNAT.OS_Lib to System.OS_Lib. + 2021-09-20 Piotr Trojanek <trojanek@adacore.com> * inline.adb (Has_Excluded_Declaration): Remove redundant guard; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index d4445f0..60cfa93 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -98,6 +98,7 @@ #ifdef __QNX__ #include <sys/syspage.h> +#include <sys/time.h> #endif #ifdef IN_RTS diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index 9074a9a..6c567c3 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -249,7 +249,6 @@ package body ALI.Util is Scan_ALI (F => Afile, T => Text, - Ignore_ED => False, Err => False); Free (Text); diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 24f1677..3815a70 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -892,7 +892,6 @@ package body ALI is function Scan_ALI (F : File_Name_Type; T : Text_Buffer_Ptr; - Ignore_ED : Boolean; Err : Boolean; Ignore_Lines : String := "X"; Ignore_Errors : Boolean := False; @@ -1319,8 +1318,7 @@ package body ALI is exit when Nextc = ','; -- Terminate if left bracket not part of wide char - -- sequence Note that we only recognize brackets - -- notation so far ??? + -- sequence. exit when Nextc = '[' and then T (P + 1) /= '"'; @@ -2938,9 +2936,7 @@ package body ALI is -- Store AD indication unless ignore required - if not Ignore_ED then - Withs.Table (Withs.Last).Elab_All_Desirable := True; - end if; + Withs.Table (Withs.Last).Elab_All_Desirable := True; elsif Nextc = 'E' then P := P + 1; @@ -2957,12 +2953,9 @@ package body ALI is Checkc ('D'); Check_At_End_Of_Field; - -- Store ED indication unless ignore required + -- Store ED indication - if not Ignore_ED then - Withs.Table (Withs.Last).Elab_Desirable := - True; - end if; + Withs.Table (Withs.Last).Elab_Desirable := True; end if; else @@ -3213,13 +3206,10 @@ package body ALI is Skip_Space; Sdep.Increment_Last; - -- In the following call, Lower is not set to True, this is either - -- a bug, or it deserves a special comment as to why this is so??? - -- The file/path name may be quoted Sdep.Table (Sdep.Last).Sfile := - Get_File_Name (May_Be_Quoted => True); + Get_File_Name (Lower => True, May_Be_Quoted => True); Sdep.Table (Sdep.Last).Stamp := Get_Stamp; Sdep.Table (Sdep.Last).Dummy_Entry := diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 3ac9f0e..175aea9 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -1389,7 +1389,6 @@ package ALI is function Scan_ALI (F : File_Name_Type; T : Text_Buffer_Ptr; - Ignore_ED : Boolean; Err : Boolean; Ignore_Lines : String := "X"; Ignore_Errors : Boolean := False; @@ -1399,11 +1398,6 @@ package ALI is -- table. Switch settings may be modified as described above in the -- switch description settings. -- - -- Ignore_ED is normally False. If set to True, it indicates that - -- all AD/ED (elaboration desirable) indications in the ALI file are - -- to be ignored. This parameter is obsolete now that the -f switch - -- is removed from gnatbind, and should be removed ??? - -- -- Err determines the action taken on an incorrectly formatted file. -- If Err is False, then an error message is output, and the program -- is terminated. If Err is True, then no error message is output, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 0f9ed23..ab11bfd 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -89,6 +89,7 @@ package Aspects is Aspect_Default_Storage_Pool, Aspect_Default_Value, Aspect_Depends, -- GNAT + Aspect_Designated_Storage_Model, -- GNAT Aspect_Dimension, -- GNAT Aspect_Dimension_System, -- GNAT Aspect_Dispatching_Domain, @@ -147,6 +148,7 @@ package Aspects is Aspect_SPARK_Mode, -- GNAT Aspect_Stable_Properties, Aspect_Static_Predicate, + Aspect_Storage_Model_Type, -- GNAT Aspect_Storage_Pool, Aspect_Storage_Size, Aspect_Stream_Size, @@ -187,6 +189,7 @@ package Aspects is Aspect_Atomic_Components, Aspect_Disable_Controlled, -- GNAT Aspect_Discard_Names, + Aspect_CUDA_Device, -- GNAT Aspect_CUDA_Global, -- GNAT Aspect_Exclusive_Functions, Aspect_Export, @@ -233,7 +236,7 @@ package Aspects is Aspect_Implicit_Dereference | Aspect_Constant_Indexing | Aspect_Variable_Indexing | Aspect_Aggregate | Aspect_Max_Entry_Queue_Length - -- | Aspect_No_Controlled_Parts + | Aspect_No_Controlled_Parts -- ??? No_Controlled_Parts not yet in Aspect_Id enumeration ; -- see RM 13.1.1(18.7) @@ -379,6 +382,7 @@ package Aspects is Aspect_Default_Storage_Pool => Expression, Aspect_Default_Value => Expression, Aspect_Depends => Expression, + Aspect_Designated_Storage_Model => Name, Aspect_Dimension => Expression, Aspect_Dimension_System => Expression, Aspect_Dispatching_Domain => Expression, @@ -437,6 +441,7 @@ package Aspects is Aspect_SPARK_Mode => Optional_Name, Aspect_Stable_Properties => Expression, Aspect_Static_Predicate => Expression, + Aspect_Storage_Model_Type => Expression, Aspect_Storage_Pool => Name, Aspect_Storage_Size => Expression, Aspect_Stream_Size => Expression, @@ -476,6 +481,7 @@ package Aspects is Aspect_Contract_Cases => False, Aspect_Convention => True, Aspect_CPU => False, + Aspect_CUDA_Device => False, Aspect_CUDA_Global => False, Aspect_Default_Component_Value => True, Aspect_Default_Initial_Condition => False, @@ -483,6 +489,7 @@ package Aspects is Aspect_Default_Storage_Pool => True, Aspect_Default_Value => True, Aspect_Depends => False, + Aspect_Designated_Storage_Model => True, Aspect_Dimension => False, Aspect_Dimension_System => False, Aspect_Dispatching_Domain => False, @@ -542,6 +549,7 @@ package Aspects is Aspect_SPARK_Mode => False, Aspect_Stable_Properties => False, Aspect_Static_Predicate => False, + Aspect_Storage_Model_Type => False, Aspect_Storage_Pool => True, Aspect_Storage_Size => True, Aspect_Stream_Size => True, @@ -627,6 +635,7 @@ package Aspects is Aspect_Contract_Cases => Name_Contract_Cases, Aspect_Convention => Name_Convention, Aspect_CPU => Name_CPU, + Aspect_CUDA_Device => Name_CUDA_Device, Aspect_CUDA_Global => Name_CUDA_Global, Aspect_Default_Component_Value => Name_Default_Component_Value, Aspect_Default_Initial_Condition => Name_Default_Initial_Condition, @@ -634,6 +643,7 @@ package Aspects is Aspect_Default_Storage_Pool => Name_Default_Storage_Pool, Aspect_Default_Value => Name_Default_Value, Aspect_Depends => Name_Depends, + Aspect_Designated_Storage_Model => Name_Designated_Storage_Model, Aspect_Dimension => Name_Dimension, Aspect_Dimension_System => Name_Dimension_System, Aspect_Disable_Controlled => Name_Disable_Controlled, @@ -723,6 +733,7 @@ package Aspects is Aspect_Stable_Properties => Name_Stable_Properties, Aspect_Static => Name_Static, Aspect_Static_Predicate => Name_Static_Predicate, + Aspect_Storage_Model_Type => Name_Storage_Model_Type, Aspect_Storage_Pool => Name_Storage_Pool, Aspect_Storage_Size => Name_Storage_Size, Aspect_Stream_Size => Name_Stream_Size, @@ -872,11 +883,13 @@ package Aspects is Aspect_Attach_Handler => Always_Delay, Aspect_Constant_Indexing => Always_Delay, Aspect_CPU => Always_Delay, + Aspect_CUDA_Device => Always_Delay, Aspect_CUDA_Global => Always_Delay, Aspect_Default_Iterator => Always_Delay, Aspect_Default_Storage_Pool => Always_Delay, Aspect_Default_Value => Always_Delay, Aspect_Default_Component_Value => Always_Delay, + Aspect_Designated_Storage_Model => Always_Delay, Aspect_Discard_Names => Always_Delay, Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, @@ -928,6 +941,7 @@ package Aspects is Aspect_Simple_Storage_Pool => Always_Delay, Aspect_Simple_Storage_Pool_Type => Always_Delay, Aspect_Static_Predicate => Always_Delay, + Aspect_Storage_Model_Type => Always_Delay, Aspect_Storage_Pool => Always_Delay, Aspect_Stream_Size => Always_Delay, Aspect_String_Literal => Always_Delay, diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 540d4ff..98614e8 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -23,20 +23,12 @@ -- -- ------------------------------------------------------------------------------ --- Assertions in this package are too slow, and are mostly needed when working --- on this package itself, or on gen_il, so we disable them. --- To debug low-level bugs in this area, comment out the following pragma, --- and run with -gnatd_v. - -pragma Assertion_Policy (Ignore); - with Aspects; use Aspects; with Debug; use Debug; with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; with Output; use Output; -with Seinfo; use Seinfo; with Sinfo.Utils; use Sinfo.Utils; with System.Storage_Elements; @@ -153,7 +145,11 @@ package body Atree is function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count; -- Number of slots belonging to N. This can be less than - -- Size_In_Slots_To_Alloc for entities. + -- Size_In_Slots_To_Alloc for entities. Includes both header + -- and dynamic slots. + + function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count; + -- Just counts the number of dynamic slots function Size_In_Slots_To_Alloc (N : Node_Or_Entity_Id) return Slot_Count; function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count; @@ -161,35 +157,47 @@ package body Atree is -- to allocate the max, because we don't know the Ekind when this is -- called. - function Off_0 (N : Node_Id) return Node_Offset; - -- Offset of the first slot of N (offset 0) in Slots.Table + function Off_F (N : Node_Id) return Node_Offset with Inline; + -- Offset of the first dynamic slot of N in Slots.Table. + -- The actual offset of this slot from the start of the node + -- is not 0; this is logically the first slot after the header + -- slots. - function Off_L (N : Node_Id) return Node_Offset; + function Off_0 (N : Node_Id) return Node_Offset'Base with Inline; + -- This is for zero-origin addressing of the dynamic slots. + -- It points to slot 0 of N in Slots.Table, which does not exist, + -- because the first few slots are stored in the header. + + function Off_L (N : Node_Id) return Node_Offset with Inline; -- Offset of the last slot of N in Slots.Table - procedure Zero_Slots (First, Last : Node_Offset) with Inline; - -- Set slots in the range F..L to zero + procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) with Inline; + -- Set dynamic slots in the range First..Last to zero + + procedure Zero_Header_Slots (N : Node_Or_Entity_Id) with Inline; + -- Zero the header slots belonging to N procedure Zero_Slots (N : Node_Or_Entity_Id) with Inline; - -- Zero the slots belonging to N + -- Zero the slots belonging to N (both header and dynamic) - procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count) + procedure Copy_Dynamic_Slots + (From, To : Node_Offset; Num_Slots : Slot_Count) with Inline; -- Copy Num_Slots slots from From to To. Caller is responsible for ensuring -- that the Num_Slots at To are a reasonable place to copy to. procedure Copy_Slots (Source, Destination : Node_Id) with Inline; - -- Copies the slots of Source to Destination; uses the node kind to - -- determine the Num_Slots. + -- Copies the slots (both header and dynamic) of Source to Destination; + -- uses the node kind to determine the Num_Slots. function Get_Field_Value - (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit; + (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit; -- Get any field value as a Field_Size_32_Bit. If the field is smaller than -- 32 bits, convert it to Field_Size_32_Bit. The Field must be present in -- the Nkind of N. procedure Set_Field_Value - (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit); + (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit); -- Set any field value as a Field_Size_32_Bit. If the field is smaller than -- 32 bits, convert it from Field_Size_32_Bit, and Val had better be small -- enough. The Field must be present in the Nkind of N. @@ -199,10 +207,6 @@ package body Atree is -- Called whenever Nkind is modified. Raises an exception if not all -- vanishing fields are in their initial zero state. - function Get_Field_Value - (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit; - procedure Set_Field_Value - (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit); procedure Check_Vanishing_Fields (Old_N : Entity_Id; New_Kind : Entity_Kind); -- Above are the same as the ones for nodes, but for entities @@ -405,7 +409,8 @@ package body Atree is pragma Assert (N'Valid); pragma Assert (N <= Node_Offsets.Last); - pragma Assert (Off_0 (N) <= Off_L (N)); + pragma Assert (Off_L (N) >= Off_0 (N)); + pragma Assert (Off_L (N) >= Off_F (N) - 1); pragma Assert (Off_L (N) <= Slots.Last); pragma Assert (Nkind (N)'Valid); pragma Assert (Nkind (N) /= N_Unused_At_End); @@ -469,8 +474,9 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_1_Bit, Field_Type); + Val : constant Field_Size_1_Bit := Get_1_Bit_Val (N, Offset); begin - return Cast (Get_1_Bit_Val (N, Offset)); + return Cast (Val); end Get_1_Bit_Field; function Get_2_Bit_Field @@ -480,8 +486,9 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_2_Bit, Field_Type); + Val : constant Field_Size_2_Bit := Get_2_Bit_Val (N, Offset); begin - return Cast (Get_2_Bit_Val (N, Offset)); + return Cast (Val); end Get_2_Bit_Field; function Get_4_Bit_Field @@ -491,8 +498,9 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_4_Bit, Field_Type); + Val : constant Field_Size_4_Bit := Get_4_Bit_Val (N, Offset); begin - return Cast (Get_4_Bit_Val (N, Offset)); + return Cast (Val); end Get_4_Bit_Field; function Get_8_Bit_Field @@ -502,8 +510,9 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_8_Bit, Field_Type); + Val : constant Field_Size_8_Bit := Get_8_Bit_Val (N, Offset); begin - return Cast (Get_8_Bit_Val (N, Offset)); + return Cast (Val); end Get_8_Bit_Field; function Get_32_Bit_Field @@ -514,7 +523,8 @@ package body Atree is function Cast is new Unchecked_Conversion (Field_Size_32_Bit, Field_Type); - Result : constant Field_Type := Cast (Get_32_Bit_Val (N, Offset)); + Val : constant Field_Size_32_Bit := Get_32_Bit_Val (N, Offset); + Result : constant Field_Type := Cast (Val); -- Note: declaring Result here instead of directly returning -- Cast (...) helps CodePeer understand that there are no issues -- around uninitialized variables. @@ -612,138 +622,228 @@ package body Atree is Set_32_Bit_Val (N, Offset, Cast (Val)); end Set_32_Bit_Field; + pragma Style_Checks ("M90"); + + ----------------------------------- + -- Low-level getters and setters -- + ----------------------------------- + + -- In the getters and setters below, we use shifting and masking to + -- simulate packed arrays. F_Size is the field size in bits. Mask is + -- that number of 1 bits in the low-order bits. F_Per_Slot is the number + -- of fields per slot. Slot_Off is the offset of the slot of interest. + -- S is the slot at that offset. V is the amount to shift by. + + function In_NH (Slot_Off : Field_Offset) return Boolean is + (Slot_Off < N_Head); + -- In_NH stands for "in Node_Header", not "in New Hampshire" + + function Get_Slot + (N : Node_Or_Entity_Id; Slot_Off : Field_Offset) + return Slot is + (if In_NH (Slot_Off) then + Node_Offsets.Table (N).Slots (Slot_Off) + else Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off)); + -- Get the slot value, either directly from the node header, or + -- indirectly from the Slots table. + + procedure Set_Slot + (N : Node_Or_Entity_Id; Slot_Off : Field_Offset; S : Slot); + -- Set the slot value, either directly from the node header, or + -- indirectly from the Slots table, to S. + function Get_1_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_1_Bit is - -- We wish we were using packed arrays, but instead we're simulating - -- them with modular integers. L here (and elsewhere) is the 'Length - -- of that simulated array. - L : constant Field_Offset := Slot_Size / 1; - - pragma Debug (Validate_Node_And_Offset (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 1; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); + Raw : constant Field_Size_1_Bit := + Field_Size_1_Bit (Shift_Right (S, V) and Mask); begin - return Field_Size_1_Bit (Shift_Right (S, V) and 1); + return Raw; end Get_1_Bit_Val; function Get_2_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_2_Bit is - L : constant Field_Offset := Slot_Size / 2; - - pragma Debug (Validate_Node_And_Offset (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 2; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); + Raw : constant Field_Size_2_Bit := + Field_Size_2_Bit (Shift_Right (S, V) and Mask); begin - return Field_Size_2_Bit (Shift_Right (S, V) and 3); + return Raw; end Get_2_Bit_Val; function Get_4_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_4_Bit is - L : constant Field_Offset := Slot_Size / 4; - - pragma Debug (Validate_Node_And_Offset (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 4; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); + Raw : constant Field_Size_4_Bit := + Field_Size_4_Bit (Shift_Right (S, V) and Mask); begin - return Field_Size_4_Bit (Shift_Right (S, V) and 15); + return Raw; end Get_4_Bit_Val; function Get_8_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_8_Bit is - L : constant Field_Offset := Slot_Size / 8; - - pragma Debug (Validate_Node_And_Offset (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 8; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); + Raw : constant Field_Size_8_Bit := + Field_Size_8_Bit (Shift_Right (S, V) and Mask); begin - return Field_Size_8_Bit (Shift_Right (S, V) and 255); + return Raw; end Get_8_Bit_Val; function Get_32_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_32_Bit is - pragma Debug (Validate_Node_And_Offset (N, Offset)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset); + F_Size : constant := 32; + -- No Mask needed + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + pragma Debug (Validate_Node_And_Offset (N, Slot_Off)); + Raw : constant Field_Size_32_Bit := + Field_Size_32_Bit (S); begin - return Field_Size_32_Bit (S); + return Raw; end Get_32_Bit_Val; + procedure Set_Slot + (N : Node_Or_Entity_Id; Slot_Off : Field_Offset; S : Slot) is + begin + if In_NH (Slot_Off) then + Node_Offsets.Table (N).Slots (Slot_Off) := S; + else + Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off) := S; + end if; + end Set_Slot; + procedure Set_1_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_1_Bit) is - L : constant Field_Offset := Slot_Size / 1; - - pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 1; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); begin - S := (S and not Shift_Left (1, V)) or Shift_Left (Slot (Val), V); + Set_Slot + (N, Slot_Off, + (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); end Set_1_Bit_Val; procedure Set_2_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_2_Bit) is - L : constant Field_Offset := Slot_Size / 2; - - pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 2; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); begin - S := (S and not Shift_Left (3, V)) or Shift_Left (Slot (Val), V); + Set_Slot + (N, Slot_Off, + (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); end Set_2_Bit_Val; procedure Set_4_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_4_Bit) is - L : constant Field_Offset := Slot_Size / 4; - - pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 4; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); begin - S := (S and not Shift_Left (15, V)) or Shift_Left (Slot (Val), V); + Set_Slot + (N, Slot_Off, + (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); end Set_4_Bit_Val; procedure Set_8_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_8_Bit) is - L : constant Field_Offset := Slot_Size / 8; - - pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L); - V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L)); + F_Size : constant := 8; + Mask : constant := 2**F_Size - 1; + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + S : constant Slot := Get_Slot (N, Slot_Off); + V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size); + pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); begin - S := (S and not Shift_Left (255, V)) or Shift_Left (Slot (Val), V); + Set_Slot + (N, Slot_Off, + (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V)); end Set_8_Bit_Val; procedure Set_32_Bit_Val (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_32_Bit) is - pragma Debug (Validate_Node_And_Offset_Write (N, Offset)); - - S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset); + F_Size : constant := 32; + -- No Mask needed; this one doesn't do read-modify-write + F_Per_Slot : constant Field_Offset := Slot_Size / F_Size; + Slot_Off : constant Field_Offset := Offset / F_Per_Slot; + pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off)); begin - S := Slot (Val); + Set_Slot (N, Slot_Off, Slot (Val)); end Set_32_Bit_Val; + ---------------------- + -- Print_Atree_Info -- + ---------------------- + + procedure Print_Atree_Info (N : Node_Or_Entity_Id) is + function Cast is new Unchecked_Conversion (Slot, Int); + begin + Write_Int (Int (Size_In_Slots (N))); + Write_Str (" slots ("); + Write_Int (Int (Off_0 (N))); + Write_Str (" .. "); + Write_Int (Int (Off_L (N))); + Write_Str ("):"); + + for Off in Off_0 (N) .. Off_L (N) loop + Write_Str (" "); + Write_Int (Cast (Get_Slot (N, Off))); + end loop; + + Write_Eol; + end Print_Atree_Info; + end Atree_Private_Part; - --------------- - -- Set_Field -- - --------------- + --------------------- + -- Get_Field_Value -- + --------------------- function Get_Node_Field_Union is new Get_32_Bit_Field (Union_Id) with Inline; @@ -751,10 +851,9 @@ package body Atree is -- etc. function Get_Field_Value - (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit + (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit is - pragma Assert (Field_Checking.Field_Present (Nkind (N), Field)); - Desc : Field_Descriptor renames Node_Field_Descriptors (Field); + Desc : Field_Descriptor renames Field_Descriptors (Field); begin case Field_Size (Desc.Kind) is @@ -766,11 +865,14 @@ package body Atree is end case; end Get_Field_Value; + --------------------- + -- Set_Field_Value -- + --------------------- + procedure Set_Field_Value - (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit) + (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit) is - pragma Assert (Field_Checking.Field_Present (Nkind (N), Field)); - Desc : Field_Descriptor renames Node_Field_Descriptors (Field); + Desc : Field_Descriptor renames Field_Descriptors (Field); begin case Field_Size (Desc.Kind) is @@ -782,13 +884,15 @@ package body Atree is end case; end Set_Field_Value; - procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field) is + procedure Reinit_Field_To_Zero + (N : Node_Id; Field : Node_Or_Entity_Field) + is begin Set_Field_Value (N, Field, 0); end Reinit_Field_To_Zero; function Field_Is_Initial_Zero - (N : Node_Id; Field : Node_Field) return Boolean is + (N : Node_Id; Field : Node_Or_Entity_Field) return Boolean is begin return Get_Field_Value (N, Field) = 0; end Field_Is_Initial_Zero; @@ -814,7 +918,7 @@ package body Atree is Old_Kind : constant Node_Kind := Nkind (Old_N); -- If this fails, it means you need to call Reinit_Field_To_Zero before - -- calling Set_Nkind. + -- calling Mutate_Nkind. begin for J in Node_Field_Table (Old_Kind)'Range loop @@ -839,47 +943,6 @@ package body Atree is end loop; end Check_Vanishing_Fields; - function Get_Field_Value - (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit - is - pragma Assert (Field_Checking.Field_Present (Ekind (N), Field)); - Desc : Field_Descriptor renames Entity_Field_Descriptors (Field); - begin - case Field_Size (Desc.Kind) is - when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset)); - when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset)); - when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset)); - when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset)); - when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32 - end case; - end Get_Field_Value; - - procedure Set_Field_Value - (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit) - is - pragma Assert (Field_Checking.Field_Present (Ekind (N), Field)); - Desc : Field_Descriptor renames Entity_Field_Descriptors (Field); - begin - case Field_Size (Desc.Kind) is - when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_Size_1_Bit (Val)); - when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_Size_2_Bit (Val)); - when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_Size_4_Bit (Val)); - when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_Size_8_Bit (Val)); - when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32 - end case; - end Set_Field_Value; - - procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field) is - begin - Set_Field_Value (N, Field, 0); - end Reinit_Field_To_Zero; - - function Field_Is_Initial_Zero - (N : Entity_Id; Field : Entity_Field) return Boolean is - begin - return Get_Field_Value (N, Field) = 0; - end Field_Is_Initial_Zero; - procedure Check_Vanishing_Fields (Old_N : Entity_Id; New_Kind : Entity_Kind) is @@ -918,13 +981,17 @@ package body Atree is end Check_Vanishing_Fields; Nkind_Offset : constant Field_Offset := - Node_Field_Descriptors (F_Nkind).Offset; + Field_Descriptors (F_Nkind).Offset; procedure Set_Node_Kind_Type is new Set_8_Bit_Field (Node_Kind) with Inline; procedure Init_Nkind (N : Node_Id; Val : Node_Kind) is pragma Assert (Field_Is_Initial_Zero (N, F_Nkind)); begin + if Atree_Statistics_Enabled then + Set_Count (F_Nkind) := Set_Count (F_Nkind) + 1; + end if; + Set_Node_Kind_Type (N, Nkind_Offset, Val); end Init_Nkind; @@ -943,35 +1010,47 @@ package body Atree is if Old_Size < New_Size then declare Old_Last_Slot : constant Node_Offset := Slots.Last; - Old_Off_0 : constant Node_Offset := Off_0 (N); + Old_Off_F : constant Node_Offset := Off_F (N); begin - if Old_Last_Slot = Old_Off_0 + Old_Size - 1 then + if Old_Last_Slot = Old_Off_F + Old_Size - 1 then -- In this case, the slots are at the end of Slots.Table, so we -- don't need to move them. Slots.Set_Last (Old_Last_Slot + New_Size - Old_Size); else -- Move the slots - All_Node_Offsets (N) := Alloc_Slots (New_Size); - Copy_Slots (Old_Off_0, Off_0 (N), Old_Size); - pragma Debug (Zero_Slots (Old_Off_0, Old_Off_0 + Old_Size - 1)); + + declare + New_Off_F : constant Node_Offset := Alloc_Slots (New_Size); + begin + All_Node_Offsets (N).Offset := New_Off_F - N_Head; + Copy_Dynamic_Slots (Old_Off_F, New_Off_F, Old_Size); + pragma Debug + (Zero_Dynamic_Slots (Old_Off_F, Old_Off_F + Old_Size - 1)); + end; end if; end; - Zero_Slots (Off_0 (N) + Old_Size, Slots.Last); + Zero_Dynamic_Slots (Off_F (N) + Old_Size, Slots.Last); + end if; + + if Atree_Statistics_Enabled then + Set_Count (F_Nkind) := Set_Count (F_Nkind) + 1; end if; Set_Node_Kind_Type (N, Nkind_Offset, Val); pragma Debug (Validate_Node_Write (N)); + + New_Node_Debugging_Output (N); end Mutate_Nkind; procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) is begin - Mutate_Nkind (N, Val, Old_Size => Size_In_Slots (N)); + Mutate_Nkind (N, Val, Old_Size => Size_In_Slots_Dynamic (N)); end Mutate_Nkind; Ekind_Offset : constant Field_Offset := - Entity_Field_Descriptors (F_Ekind).Offset; + Field_Descriptors (F_Ekind).Offset; procedure Set_Entity_Kind_Type is new Set_8_Bit_Field (Entity_Kind) with Inline; @@ -991,8 +1070,14 @@ package body Atree is -- For now, we are allocating all entities with the same size, so we -- don't need to reallocate slots here. + if Atree_Statistics_Enabled then + Set_Count (F_Nkind) := Set_Count (F_Ekind) + 1; + end if; + Set_Entity_Kind_Type (N, Ekind_Offset, Val); pragma Debug (Validate_Node_Write (N)); + + New_Node_Debugging_Output (N); end Mutate_Ekind; ----------------------- @@ -1006,8 +1091,9 @@ package body Atree is Sz : constant Slot_Count := Size_In_Slots_To_Alloc (Kind); Sl : constant Node_Offset := Alloc_Slots (Sz); begin - Node_Offsets.Table (Result) := Sl; - Zero_Slots (Sl, Sl + Sz - 1); + Node_Offsets.Table (Result).Offset := Sl - N_Head; + Zero_Dynamic_Slots (Sl, Sl + Sz - 1); + Zero_Header_Slots (Result); end; Init_Nkind (Result, Kind); @@ -1045,7 +1131,7 @@ package body Atree is pragma Assert (Nkind (N) not in N_Entity); pragma Assert (New_Kind not in N_Entity); - Old_Size : constant Slot_Count := Size_In_Slots (N); + Old_Size : constant Slot_Count := Size_In_Slots_Dynamic (N); New_Size : constant Slot_Count := Size_In_Slots_To_Alloc (New_Kind); Save_Sloc : constant Source_Ptr := Sloc (N); @@ -1068,15 +1154,16 @@ package body Atree is New_Offset : constant Field_Offset := Alloc_Slots (New_Size); begin pragma Debug (Zero_Slots (N)); - Node_Offsets.Table (N) := New_Offset; - Zero_Slots (New_Offset, New_Offset + New_Size - 1); + Node_Offsets.Table (N).Offset := New_Offset - N_Head; + Zero_Dynamic_Slots (New_Offset, New_Offset + New_Size - 1); + Zero_Header_Slots (N); end; else Zero_Slots (N); end if; - Mutate_Nkind (N, New_Kind, Old_Size); + Init_Nkind (N, New_Kind); -- Not Mutate, because of Zero_Slots above Set_Sloc (N, Save_Sloc); Set_In_List (N, Save_In_List); @@ -1095,8 +1182,10 @@ package body Atree is -- Copy_Slots -- ---------------- - procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count) is - pragma Assert (From /= To); + procedure Copy_Dynamic_Slots + (From, To : Node_Offset; Num_Slots : Slot_Count) + is + pragma Assert (if Num_Slots /= 0 then From /= To); All_Slots : Slots.Table_Type renames Slots.Table (Slots.First .. Slots.Last); @@ -1109,21 +1198,21 @@ package body Atree is begin Destination_Slots := Source_Slots; - end Copy_Slots; + end Copy_Dynamic_Slots; procedure Copy_Slots (Source, Destination : Node_Id) is pragma Debug (Validate_Node (Source)); - pragma Debug (Validate_Node_Write (Destination)); pragma Assert (Source /= Destination); - S_Size : constant Slot_Count := Size_In_Slots (Source); + S_Size : constant Slot_Count := Size_In_Slots_Dynamic (Source); All_Node_Offsets : Node_Offsets.Table_Type renames Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); begin - Copy_Slots - (All_Node_Offsets (Source), All_Node_Offsets (Destination), S_Size); + Copy_Dynamic_Slots + (Off_F (Source), Off_F (Destination), S_Size); + All_Node_Offsets (Destination).Slots := All_Node_Offsets (Source).Slots; end Copy_Slots; --------------- @@ -1152,14 +1241,14 @@ package body Atree is if D_Size < S_Size then pragma Debug (Zero_Slots (Destination)); -- destroy old slots - Node_Offsets.Table (Destination) := Alloc_Slots (S_Size); + Node_Offsets.Table (Destination).Offset := + Alloc_Slots (S_Size) - N_Head; end if; Copy_Slots (Source, Destination); Set_In_List (Destination, Save_In_List); Set_Link (Destination, Save_Link); - Set_Paren_Count_Of_Copy (Target => Destination, Source => Source); end Copy_Node; @@ -1371,7 +1460,7 @@ package body Atree is (Is_Entity (E1) and then Is_Entity (E2) and then not In_List (E1) and then not In_List (E2)); - Old_E1 : constant Node_Offset := Node_Offsets.Table (E1); + Old_E1 : constant Node_Header := Node_Offsets.Table (E1); begin Node_Offsets.Table (E1) := Node_Offsets.Table (E2); @@ -1404,6 +1493,7 @@ package body Atree is pragma Assert (not Is_Entity (Source)); Old_Kind : constant Node_Kind := Nkind (Source); + pragma Assert (Old_Kind in N_Direct_Name); New_Kind : constant Node_Kind := (case Old_Kind is when N_Character_Literal => N_Defining_Character_Literal, @@ -1469,8 +1559,7 @@ package body Atree is begin for J in Fields'Range loop declare - Desc : Field_Descriptor renames - Node_Field_Descriptors (Fields (J)); + Desc : Field_Descriptor renames Field_Descriptors (Fields (J)); begin if Desc.Kind in Node_Id_Field | List_Id_Field then Fix_Parent (Get_Node_Field_Union (Fix_Node, Desc.Offset)); @@ -1620,7 +1709,8 @@ package body Atree is end if; return New_Id : constant Node_Id := Alloc_Node_Id do - Node_Offsets.Table (New_Id) := Alloc_Slots (S_Size); + Node_Offsets.Table (New_Id).Offset := + Alloc_Slots (S_Size) - N_Head; Orig_Nodes.Append (New_Id); Copy_Slots (Source, New_Id); @@ -1676,7 +1766,7 @@ package body Atree is -- source nodes, then reset Current_Error_Node. This is useful -- if we bomb during parsing to get a error location for the bomb. - if New_Sloc > No_Location and then Comes_From_Source_Default then + if New_Sloc > No_Location and then Comes_From_Source_Default then Current_Error_Node := New_Id; end if; @@ -1765,16 +1855,25 @@ package body Atree is -- Off_0 -- ----------- - function Off_0 (N : Node_Id) return Node_Offset is + function Off_0 (N : Node_Id) return Node_Offset'Base is pragma Debug (Validate_Node (N)); All_Node_Offsets : Node_Offsets.Table_Type renames Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); begin - return All_Node_Offsets (N); + return All_Node_Offsets (N).Offset; end Off_0; ----------- + -- Off_F -- + ----------- + + function Off_F (N : Node_Id) return Node_Offset is + begin + return Off_0 (N) + N_Head; + end Off_F; + + ----------- -- Off_L -- ----------- @@ -1784,7 +1883,7 @@ package body Atree is All_Node_Offsets : Node_Offsets.Table_Type renames Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); begin - return All_Node_Offsets (N) + Size_In_Slots (N) - 1; + return All_Node_Offsets (N).Offset + Size_In_Slots (N) - 1; end Off_L; ------------------- @@ -1794,6 +1893,9 @@ package body Atree is function Original_Node (Node : Node_Id) return Node_Id is begin pragma Debug (Validate_Node (Node)); + if Atree_Statistics_Enabled then + Get_Original_Node_Count := Get_Original_Node_Count + 1; + end if; return Orig_Nodes.Table (Node); end Original_Node; @@ -1855,28 +1957,6 @@ package body Atree is Set_Comes_From_Source (NewN, Comes_From_Source (OldN)); end Preserve_Comes_From_Source; - ---------------------- - -- Print_Atree_Info -- - ---------------------- - - procedure Print_Atree_Info (N : Node_Or_Entity_Id) is - function Cast is new Unchecked_Conversion (Slot, Int); - begin - Write_Int (Int (Size_In_Slots (N))); - Write_Str (" slots ("); - Write_Int (Int (Off_0 (N))); - Write_Str (" .. "); - Write_Int (Int (Off_L (N))); - Write_Str ("):"); - - for Off in Off_0 (N) .. Off_L (N) loop - Write_Str (" "); - Write_Int (Cast (Slots.Table (Off))); - end loop; - - Write_Eol; - end Print_Atree_Info; - ------------------- -- Relocate_Node -- ------------------- @@ -1908,6 +1988,22 @@ package body Atree is Set_Original_Node (New_Node, Original_Node (Source)); end if; + -- If we're relocating a subprogram call and we're doing + -- unnesting, be sure we make a new copy of any parameter associations + -- so that we don't share them. + + if Nkind (Source) in N_Subprogram_Call + and then Opt.Unnest_Subprogram_Mode + and then Present (Parameter_Associations (Source)) + then + declare + New_Assoc : constant List_Id := Parameter_Associations (Source); + begin + Set_Parent (New_Assoc, New_Node); + Set_Parameter_Associations (New_Node, New_Assoc); + end; + end if; + return New_Node; end Relocate_Node; @@ -1926,7 +2022,7 @@ package body Atree is procedure Destroy_New_Node is begin Zero_Slots (New_Node); - Node_Offsets.Table (New_Node) := Field_Offset'Base'Last; + Node_Offsets.Table (New_Node).Offset := Field_Offset'Base'Last; end Destroy_New_Node; begin @@ -2025,10 +2121,16 @@ package body Atree is -- Both the old and new copies of the node will share the same list -- of aspect specifications if aspect specifications are present. + -- Restore the parent link of the aspect list to the old node, which + -- is the one linked in the tree. if Old_Has_Aspects then - Set_Aspect_Specifications - (Sav_Node, Aspect_Specifications (Old_Node)); + declare + Aspects : constant List_Id := Aspect_Specifications (Old_Node); + begin + Set_Aspect_Specifications (Sav_Node, Aspects); + Set_Parent (Aspects, Old_Node); + end; end if; end if; @@ -2089,6 +2191,9 @@ package body Atree is procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is begin pragma Debug (Validate_Node_Write (N)); + if Atree_Statistics_Enabled then + Set_Original_Node_Count := Set_Original_Node_Count + 1; + end if; Orig_Nodes.Table (N) := Val; end Set_Original_Node; @@ -2176,11 +2281,15 @@ package body Atree is Rewriting_Proc := Proc; end Set_Rewriting_Proc; + ---------------------------- + -- Size_In_Slots_To_Alloc -- + ---------------------------- + function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is begin return (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size - else Sinfo.Nodes.Size (Kind)); + else Sinfo.Nodes.Size (Kind)) - N_Head; -- Unfortunately, we don't know the Entity_Kind, so we have to use the -- max. end Size_In_Slots_To_Alloc; @@ -2191,6 +2300,10 @@ package body Atree is return Size_In_Slots_To_Alloc (Nkind (N)); end Size_In_Slots_To_Alloc; + ------------------- + -- Size_In_Slots -- + ------------------- + function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is begin pragma Assert (Nkind (N) /= N_Unused_At_Start); @@ -2199,6 +2312,15 @@ package body Atree is else Sinfo.Nodes.Size (Nkind (N))); end Size_In_Slots; + --------------------------- + -- Size_In_Slots_Dynamic -- + --------------------------- + + function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count is + begin + return Size_In_Slots (N) - N_Head; + end Size_In_Slots_Dynamic; + ------------------- -- Traverse_Func -- ------------------- @@ -2366,14 +2488,179 @@ package body Atree is -- Zero_Slots -- ---------------- - procedure Zero_Slots (First, Last : Node_Offset) is + procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) is begin Slots.Table (First .. Last) := (others => 0); - end Zero_Slots; + end Zero_Dynamic_Slots; + + procedure Zero_Header_Slots (N : Node_Or_Entity_Id) is + All_Node_Offsets : Node_Offsets.Table_Type renames + Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); + begin + All_Node_Offsets (N).Slots := (others => 0); + end Zero_Header_Slots; procedure Zero_Slots (N : Node_Or_Entity_Id) is begin - Zero_Slots (Off_0 (N), Off_L (N)); + Zero_Dynamic_Slots (Off_F (N), Off_L (N)); + Zero_Header_Slots (N); end Zero_Slots; + ---------------------- + -- Print_Statistics -- + ---------------------- + + procedure Print_Node_Statistics; + procedure Print_Field_Statistics; + -- Helpers for Print_Statistics + + procedure Write_Ratio (X : Nat_64; Y : Pos_64); + -- Write the value of (X/Y) without using 'Image (approximately) + + procedure Write_Ratio (X : Nat_64; Y : Pos_64) is + pragma Assert (X <= Y); + Ratio : constant Nat := Nat ((Long_Float (X) / Long_Float (Y)) * 1000.0); + begin + Write_Str (" ("); + + if Ratio = 0 then + Write_Str ("0.000"); + elsif Ratio in 1 .. 9 then + Write_Str ("0.00"); + Write_Int (Ratio); + elsif Ratio in 10 .. 99 then + Write_Str ("0.0"); + Write_Int (Ratio); + elsif Ratio in 100 .. 999 then + Write_Str ("0."); + Write_Int (Ratio); + else + Write_Int (Ratio / 1000); + end if; + + Write_Str (")"); + end Write_Ratio; + + procedure Print_Node_Statistics is + subtype Count is Nat_64; + Node_Counts : array (Node_Kind) of Count := (others => 0); + Entity_Counts : array (Entity_Kind) of Count := (others => 0); + + All_Node_Offsets : Node_Offsets.Table_Type renames + Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last); + begin + Write_Int (Int (Node_Offsets.Last)); + Write_Line (" nodes (including entities)"); + Write_Int (Int (Slots.Last)); + Write_Line (" non-header slots"); + + for N in All_Node_Offsets'Range loop + declare + K : constant Node_Kind := Nkind (N); + + begin + Node_Counts (K) := Node_Counts (K) + 1; + + if K in N_Entity then + Entity_Counts (Ekind (N)) := Entity_Counts (Ekind (N)) + 1; + end if; + end; + end loop; + + for K in Node_Kind loop + declare + Count : constant Nat_64 := Node_Counts (K); + begin + Write_Int_64 (Count); + Write_Ratio (Count, Int_64 (Node_Offsets.Last)); + Write_Str (" "); + Write_Str (Node_Kind'Image (K)); + Write_Str (" "); + Write_Int (Int (Sinfo.Nodes.Size (K))); + Write_Str (" slots"); + Write_Eol; + end; + end loop; + + for K in Entity_Kind loop + declare + Count : constant Nat_64 := Entity_Counts (K); + begin + Write_Int_64 (Count); + Write_Ratio (Count, Int_64 (Node_Offsets.Last)); + Write_Str (" "); + Write_Str (Entity_Kind'Image (K)); + Write_Str (" "); + Write_Int (Int (Einfo.Entities.Size (K))); + Write_Str (" slots"); + Write_Eol; + end; + end loop; + end Print_Node_Statistics; + + procedure Print_Field_Statistics is + Total, G_Total, S_Total : Call_Count := 0; + begin + Write_Int_64 (Get_Original_Node_Count); + Write_Str (" + "); + Write_Int_64 (Set_Original_Node_Count); + Write_Eol; + Write_Line (" Original_Node_Count getter and setter calls"); + Write_Eol; + + Write_Line ("Frequency of field getter and setter calls:"); + + for Field in Node_Or_Entity_Field loop + G_Total := G_Total + Get_Count (Field); + S_Total := S_Total + Set_Count (Field); + Total := G_Total + S_Total; + end loop; + + -- This assertion helps CodePeer understand that Total cannot be 0 (this + -- is true because GNAT does not attempt to compile empty files). + pragma Assert (Total > 0); + + Write_Int_64 (Total); + Write_Str (" (100%) = "); + Write_Int_64 (G_Total); + Write_Str (" + "); + Write_Int_64 (S_Total); + Write_Line (" total getter and setter calls"); + + for Field in Node_Or_Entity_Field loop + declare + G : constant Call_Count := Get_Count (Field); + S : constant Call_Count := Set_Count (Field); + GS : constant Call_Count := G + S; + + Desc : Field_Descriptor renames Field_Descriptors (Field); + Slot : constant Field_Offset := + (Field_Size (Desc.Kind) * Desc.Offset) / Slot_Size; + + begin + Write_Int_64 (GS); + Write_Ratio (GS, Total); + Write_Str (" = "); + Write_Int_64 (G); + Write_Str (" + "); + Write_Int_64 (S); + Write_Str (" "); + Write_Str (Node_Or_Entity_Field'Image (Field)); + Write_Str (" in slot "); + Write_Int (Int (Slot)); + Write_Str (" size "); + Write_Int (Int (Field_Size (Desc.Kind))); + Write_Eol; + end; + end loop; + end Print_Field_Statistics; + + procedure Print_Statistics is + begin + Write_Eol; + Write_Eol; + Print_Node_Statistics; + Print_Field_Statistics; + end Print_Statistics; + end Atree; diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 6fb5aa6..2f3ca40 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -48,6 +48,7 @@ with Alloc; with Sinfo.Nodes; use Sinfo.Nodes; with Einfo.Entities; use Einfo.Entities; with Types; use Types; +with Seinfo; use Seinfo; with System; use System; with Table; with Unchecked_Conversion; @@ -501,6 +502,7 @@ package Atree is -- the contents of these two nodes fixing up the parent pointers of the -- replaced node (we do not attempt to preserve parent pointers for the -- original node). Neither Old_Node nor New_Node can be extended nodes. + -- ??? The above explanation is incorrect, instead Copy_Node is called. -- -- Note: New_Node may not contain references to Old_Node, for example as -- descendants, since the rewrite would make such references invalid. If @@ -565,10 +567,9 @@ package Atree is type Entity_Field_Set is array (Entity_Field) of Boolean with Pack; - procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field); - procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field); + procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Or_Entity_Field); -- When a node is created, all fields are initialized to zero, even if zero - -- is not a valid value of the field type. These procedures put the field + -- is not a valid value of the field type. This procedure puts the field -- back to its initial zero value. Note that you can't just do something -- like Set_Some_Field (N, 0), if Some_Field is of (say) type Uintp, -- because Uintp is a subrange that does not include 0. @@ -582,9 +583,7 @@ package Atree is -- this. function Field_Is_Initial_Zero - (N : Node_Id; Field : Node_Field) return Boolean; - function Field_Is_Initial_Zero - (N : Entity_Id; Field : Entity_Field) return Boolean; + (N : Node_Id; Field : Node_Or_Entity_Field) return Boolean; -- True if the field value is the initial zero value procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) with Inline; @@ -610,10 +609,6 @@ package Atree is -- always the same; for example we change from E_Void, to E_Variable, to -- E_Void, to E_Constant. - procedure Print_Atree_Info (N : Node_Or_Entity_Id); - -- Called from Treepr to print out information about N that is private to - -- Atree. - ----------------------------- -- Private Part Subpackage -- ----------------------------- @@ -638,7 +633,7 @@ package Atree is -- The nodes of the tree are stored in two tables (i.e. growable -- arrays). - -- A Node_Id points to an element of Nodes, which contains a + -- A Node_Id points to an element of Node_Offsets, which contains a -- Field_Offset that points to an element of Slots. Each slot can -- contain a single 32-bit field, or multiple smaller fields. -- An n-bit field is aligned on an n-bit boundary. The size of a node is @@ -648,12 +643,40 @@ package Atree is -- The reason for the extra level of indirection is that Copy_Node, -- Exchange_Entities, and Rewrite all assume that nodes can be modified -- in place. + -- + -- As an optimization, we store a few slots directly in the Node_Offsets + -- table (see type Node_Header) rather than requiring the extra level of + -- indirection for accessing those slots. N_Head is the number of slots + -- stored in the Node_Header. N_Head can be adjusted by modifying + -- Gen_IL.Gen. If N_Head is (say) 3, then a node containing 7 slots will + -- have slots 0..2 in the header, and 3..6 stored indirect in the Slots + -- table. We use zero-origin addressing, so the Offset into the Slots + -- table will point 3 slots before slot 3. + + pragma Assert (N_Head <= Min_Node_Size); + pragma Assert (N_Head <= Min_Entity_Size); - subtype Node_Offset is Field_Offset'Base - range 1 .. Field_Offset'Base'Last; + Slot_Size : constant := 32; + type Slot is mod 2**Slot_Size; + for Slot'Size use Slot_Size; + + -- The type Slot is defined in Types as a 32-bit modular integer. It + -- is logically split into the appropriate numbers of components of + -- appropriate size, but this splitting is not explicit because packed + -- arrays cannot be properly interfaced in C/C++ and packed records are + -- way too slow. + + type Node_Header_Slots is + array (Field_Offset range 0 .. N_Head - 1) of Slot; + type Node_Header is record + Slots : Node_Header_Slots; + Offset : Node_Offset'Base; + end record; + pragma Assert (Node_Header'Size = (N_Head + 1) * Slot_Size); + pragma Assert (Node_Header'Size = 16 * 8); package Node_Offsets is new Table.Table - (Table_Component_Type => Node_Offset, + (Table_Component_Type => Node_Header, Table_Index_Type => Node_Id'Base, Table_Low_Bound => First_Node_Id, Table_Initial => Alloc.Node_Offsets_Initial, @@ -667,15 +690,6 @@ package Atree is -- Short names for use in gdb, not used in real code. Note that gdb -- can't find Node_Offsets.Table without a full expanded name. - -- We define the type Slot as a 32-bit modular integer. It is logically - -- split into the appropriate numbers of components of appropriate size, - -- but this splitting is not explicit because packed arrays cannot be - -- properly interfaced in C/C++ and packed records are way too slow. - - Slot_Size : constant := 32; - type Slot is mod 2**Slot_Size; - for Slot'Size use Slot_Size; - function Shift_Left (S : Slot; V : Natural) return Slot; pragma Import (Intrinsic, Shift_Left); @@ -855,6 +869,22 @@ package Atree is function Is_Valid_Node (U : Union_Id) return Boolean; -- True if U is within the range of Node_Offsets + procedure Print_Atree_Info (N : Node_Or_Entity_Id); + -- Called from Treepr to print out information about N that is private + -- to Atree. + end Atree_Private_Part; + -- Statistics: + + subtype Call_Count is Nat_64; + Get_Count, Set_Count : array (Node_Or_Entity_Field) of Call_Count := + (others => 0); + -- Number of calls to each getter and setter. See documentaton for + -- -gnatd.A. + + Get_Original_Node_Count, Set_Original_Node_Count : Call_Count := 0; + + procedure Print_Statistics; + end Atree; diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index 08b791c..7fb3bcb 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -65,77 +65,6 @@ Present (Tree_Id N) #define Current_Error_Node atree__current_error_node extern Node_Id Current_Error_Node; -/* The following code corresponds to the Get_n_Bit_Field functions (for - various n) in package Atree. The low-level getters in sinfo.h call - these even-lower-level getters. */ - -extern Field_Offset *Node_Offsets_Ptr; -extern any_slot *Slots_Ptr; - -INLINE unsigned int Get_1_Bit_Field (Node_Id, Field_Offset); -INLINE unsigned int Get_2_Bit_Field (Node_Id, Field_Offset); -INLINE unsigned int Get_4_Bit_Field (Node_Id, Field_Offset); -INLINE unsigned int Get_8_Bit_Field (Node_Id, Field_Offset); -INLINE unsigned int Get_32_Bit_Field (Node_Id, Field_Offset); -INLINE unsigned int Get_32_Bit_Field_With_Default (Node_Id, Field_Offset, - unsigned int); -INLINE unsigned int Get_Valid_32_Bit_Field (Node_Id, Field_Offset); - -INLINE unsigned int -Get_1_Bit_Field (Node_Id N, Field_Offset Offset) -{ - const Field_Offset L = Slot_Size / 1; - any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L); - return (slot >> (Offset % L) * (Slot_Size / L)) & 1; -} - -INLINE unsigned int -Get_2_Bit_Field (Node_Id N, Field_Offset Offset) -{ - const Field_Offset L = Slot_Size / 2; - any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L); - return (slot >> (Offset % L) * (Slot_Size / L)) & 3; -} - -INLINE unsigned int -Get_4_Bit_Field (Node_Id N, Field_Offset Offset) -{ - const Field_Offset L = Slot_Size / 4; - any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L); - return (slot >> (Offset % L) * (Slot_Size / L)) & 15; -} - -INLINE unsigned int -Get_8_Bit_Field (Node_Id N, Field_Offset Offset) -{ - const Field_Offset L = Slot_Size / 8; - any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L); - return (slot >> (Offset % L) * (Slot_Size / L)) & 255; -} - -INLINE unsigned int -Get_32_Bit_Field (Node_Id N, Field_Offset Offset) -{ - any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset); - return slot; -} - -INLINE unsigned int -Get_32_Bit_Field_With_Default (Node_Id N, Field_Offset Offset, - unsigned int Default_Value) -{ - any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset); - return slot == Empty ? Default_Value : slot; -} - -INLINE unsigned int -Get_Valid_32_Bit_Field (Node_Id N, Field_Offset Offset) -{ - any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset); - gcc_assert (slot != Empty); - return slot; -} - #ifdef __cplusplus } #endif diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index 804e2fd..38bf2c2 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -29,6 +29,7 @@ with Binderr; use Binderr; with Butil; use Butil; with Casing; use Casing; with Fname; use Fname; +with Gnatvsn; with Namet; use Namet; with Opt; use Opt; with Osint; @@ -1324,11 +1325,136 @@ package body Bcheck is or else ALIs.Table (A).Ver (1 .. VL) /= ALIs.Table (ALIs.First).Ver (1 .. VL) then - Error_Msg_File_1 := ALIs.Table (A).Sfile; - Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; + -- Version mismatch found; generate error message. - Consistency_Error_Msg - ("{ and { compiled with different GNAT versions"); + declare + use Gnatvsn; + + Prefix : constant String := + Verbose_Library_Version + (1 .. Verbose_Library_Version'Length + - Library_Version'Length); + + type ALI_Version is record + Primary, Secondary : Int range -1 .. Int'Last; + end record; + + No_Version : constant ALI_Version := (-1, -1); + + function Remove_Prefix (S : String) return String is + (S (S'First + Prefix'Length .. S'Last)); + + function Extract_Version (S : String) return ALI_Version; + -- Attempts to extract and return a pair of nonnegative library + -- version numbers from the given string; if unsuccessful, + -- then returns No_Version. + + --------------------- + -- Extract_Version -- + --------------------- + + function Extract_Version (S : String) return ALI_Version is + pragma Assert (S'First = 1); + + function Int_Value (Img : String) return Int; + -- Using Int'Value leads to complications in + -- building the binder, so DIY. + + --------------- + -- Int_Value -- + --------------- + + function Int_Value (Img : String) return Int is + Result : Nat := 0; + begin + if Img'Length in 1 .. 9 + and then (for all C of Img => C in '0' .. '9') + then + for C of Img loop + Result := (10 * Result) + + (Character'Pos (C) - Character'Pos ('0')); + end loop; + return Result; + else + return -1; + end if; + end Int_Value; + + begin + if S'Length > Prefix'Length + and then S (1 .. Prefix'Length) = Prefix + then + declare + Suffix : constant String := Remove_Prefix (S); + Dot_Found : Boolean := False; + Primary, Secondary : Int; + begin + for Dot_Index in Suffix'Range loop + if Suffix (Dot_Index) = '.' then + Dot_Found := True; + Primary := + Int_Value (Suffix (Suffix'First + .. Dot_Index - 1)); + Secondary := + Int_Value (Suffix (Dot_Index + 1 + .. Suffix'Last)); + exit; + end if; + end loop; + + if not Dot_Found then + Primary := Int_Value (Suffix); + Secondary := 0; + end if; + + if (Primary /= -1) and (Secondary /= -1) then + return (Primary => Primary, + Secondary => Secondary); + end if; + end; + end if; + return No_Version; + end Extract_Version; + + -- Local constants + + V1_Text : constant String := + ALIs.Table (A).Ver (1 .. ALIs.Table (A).Ver_Len); + V2_Text : constant String := + ALIs.Table (ALIs.First).Ver (1 .. VL); + V1 : constant ALI_Version := Extract_Version (V1_Text); + V2 : constant ALI_Version := Extract_Version (V2_Text); + + Include_Version_Numbers_In_Message : constant Boolean := + (V1 /= V2) and (V1 /= No_Version) and (V2 /= No_Version); + begin + Error_Msg_File_1 := ALIs.Table (A).Sfile; + Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile; + + if Include_Version_Numbers_In_Message then + if V1.Secondary = V2.Secondary then + -- Excluding equal secondary values from error + -- message text matters for generating reproducible + -- regression test outputs. + + Error_Msg_Nat_1 := V1.Primary; + Error_Msg_Nat_2 := V2.Primary; + Consistency_Error_Msg + ("{ and { compiled with different GNAT versions" + & ", v# and v#"); + else + Consistency_Error_Msg + ("{ and { compiled with different GNAT versions" + & ", v" + & Remove_Prefix (V1_Text) + & " and v" + & Remove_Prefix (V2_Text)); + end if; + else + Consistency_Error_Msg + ("{ and { compiled with different GNAT versions"); + end if; + end; end if; end loop; end Check_Versions; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 8f5c0b0..a58a495 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3552,9 +3552,12 @@ package body Checks is -- Apply_Subscript_Validity_Checks -- ------------------------------------- - procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is + procedure Apply_Subscript_Validity_Checks + (Expr : Node_Id; + No_Check_Needed : Dimension_Set := Empty_Dimension_Set) is Sub : Node_Id; + Dimension : Pos := 1; begin pragma Assert (Nkind (Expr) = N_Indexed_Component); @@ -3568,11 +3571,16 @@ package body Checks is -- for the subscript, and that convert will do the necessary validity -- check. - Ensure_Valid (Sub, Holes_OK => True); + if (No_Check_Needed = Empty_Dimension_Set) + or else not No_Check_Needed.Elements (Dimension) + then + Ensure_Valid (Sub, Holes_OK => True); + end if; -- Move to next subscript Next (Sub); + Dimension := Dimension + 1; end loop; end Apply_Subscript_Validity_Checks; @@ -7233,7 +7241,10 @@ package body Checks is -- Generate_Index_Checks -- --------------------------- - procedure Generate_Index_Checks (N : Node_Id) is + procedure Generate_Index_Checks + (N : Node_Id; + Checks_Generated : out Dimension_Set) + is function Entity_Of_Prefix return Entity_Id; -- Returns the entity of the prefix of N (or Empty if not found) @@ -7268,6 +7279,8 @@ package body Checks is -- Start of processing for Generate_Index_Checks begin + Checks_Generated.Elements := (others => False); + -- Ignore call if the prefix is not an array since we have a serious -- error in the sources. Ignore it also if index checks are suppressed -- for array object or type. @@ -7330,6 +7343,8 @@ package body Checks is Prefix => New_Occurrence_Of (Etype (A), Loc), Attribute_Name => Name_Range)), Reason => CE_Index_Check_Failed)); + + Checks_Generated.Elements (1) := True; end if; -- General case @@ -7416,6 +7431,8 @@ package body Checks is Duplicate_Subexpr_Move_Checks (Sub)), Right_Opnd => Range_N), Reason => CE_Index_Check_Failed)); + + Checks_Generated.Elements (Ind) := True; end if; Next_Index (A_Idx); @@ -10383,7 +10400,7 @@ package body Checks is Exptyp : Entity_Id; Cond : Node_Id := Empty; Do_Access : Boolean := False; - Wnode : Node_Id := Warn_Node; + Wnode : Node_Id := Warn_Node; Ret_Result : Check_Result := (Empty, Empty); Num_Checks : Natural := 0; diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 3b97bd0..6df752f 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -44,6 +44,14 @@ with Urealp; use Urealp; package Checks is + type Bit_Vector is array (Pos range <>) of Boolean; + type Dimension_Set (Dimensions : Nat) is + record + Elements : Bit_Vector (1 .. Dimensions); + end record; + Empty_Dimension_Set : constant Dimension_Set + := (Dimensions => 0, Elements => (others => <>)); + procedure Initialize; -- Called for each new main source program, to initialize internal -- variables used in the package body of the Checks unit. @@ -721,11 +729,16 @@ package Checks is -- Do_Range_Check flag, and if it is set, this routine is called, which -- turns the flag off in code-generation mode. - procedure Generate_Index_Checks (N : Node_Id); + procedure Generate_Index_Checks + (N : Node_Id; + Checks_Generated : out Dimension_Set); -- This procedure is called to generate index checks on the subscripts for -- the indexed component node N. Each subscript expression is examined, and -- if the Do_Range_Check flag is set, an appropriate index check is -- generated and the flag is reset. + -- The out-mode parameter Checks_Generated indicates the dimensions for + -- which checks were generated. Checks_Generated.Dimensions must match + -- the number of dimensions of the array type. -- Similarly, we set the flag Do_Discriminant_Check in the semantic -- analysis to indicate that a discriminant check is required for selected @@ -858,10 +871,14 @@ package Checks is -- The following procedures are used in handling validity checking - procedure Apply_Subscript_Validity_Checks (Expr : Node_Id); + procedure Apply_Subscript_Validity_Checks + (Expr : Node_Id; + No_Check_Needed : Dimension_Set := Empty_Dimension_Set); -- Expr is the node for an indexed component. If validity checking and - -- range checking are enabled, all subscripts for this indexed component - -- are checked for validity. + -- range checking are enabled, each subscript for this indexed component + -- whose dimension does not belong to the No_Check_Needed set is checked + -- for validity. No_Check_Needed.Dimensions must match the number of + -- dimensions of the array type or be zero. procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id); -- Expr is a lvalue, i.e. an expression representing the target of an diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 03ca7a4..830a994 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -217,7 +217,7 @@ package body Clean is if Text /= null then The_ALI := - Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); + Scan_ALI (Lib_File, Text, Err => True); Free (Text); -- If no error was produced while loading this ALI file, diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 064fae0..e009c58 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -478,6 +478,7 @@ package body Comperr is when N_Package_Declaration | N_Subprogram_Body | N_Subprogram_Declaration + | N_Subprogram_Renaming_Declaration => Unit_Name := Defining_Unit_Name (Specification (Main)); @@ -489,10 +490,10 @@ package body Comperr is => Unit_Name := Defining_Unit_Name (Main); - -- No SCIL file generated for generic package declarations + -- No SCIL file generated for generic unit declarations - when N_Generic_Package_Declaration - | N_Generic_Package_Renaming_Declaration + when N_Generic_Declaration + | N_Generic_Renaming_Declaration => return; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index e37e092..2726486 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -47,6 +47,8 @@ with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; @@ -66,6 +68,16 @@ package body Contracts is -- -- Part_Of + procedure Check_Class_Condition + (Cond : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id; + Is_Precondition : Boolean); + -- Perform checking of class-wide pre/postcondition Cond inherited by Subp + -- from Par_Subp. Is_Precondition enables check specific for preconditions. + -- In SPARK_Mode, an inherited operation that is not overridden but has + -- inherited modified conditions pre/postconditions is illegal. + procedure Check_Type_Or_Object_External_Properties (Type_Or_Obj_Id : Entity_Id); -- Perform checking of external properties pragmas that is common to both @@ -77,6 +89,12 @@ package body Contracts is -- well as Contract_Cases, Subprogram_Variant, invariants and predicates. -- Body_Id denotes the entity of the subprogram body. + procedure Set_Class_Condition + (Kind : Condition_Kind; + Subp : Entity_Id; + Cond : Node_Id); + -- Set the class-wide Kind condition of Subp + ----------------------- -- Add_Contract_Item -- ----------------------- @@ -386,23 +404,7 @@ package body Contracts is | N_Generic_Subprogram_Declaration | N_Subprogram_Declaration then - declare - Subp_Id : constant Entity_Id := Defining_Entity (Decl); - - begin - Analyze_Entry_Or_Subprogram_Contract (Subp_Id); - - -- If analysis of a class-wide pre/postcondition indicates - -- that a class-wide clone is needed, analyze its declaration - -- now. Its body is created when the body of the original - -- operation is analyzed (and rewritten). - - if Is_Subprogram (Subp_Id) - and then Present (Class_Wide_Clone (Subp_Id)) - then - Analyze (Unit_Declaration_Node (Class_Wide_Clone (Subp_Id))); - end if; - end; + Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Decl)); -- Entry or subprogram bodies @@ -1491,6 +1493,141 @@ package body Contracts is (Type_Or_Obj_Id => Type_Id); end Analyze_Type_Contract; + --------------------------- + -- Check_Class_Condition -- + --------------------------- + + procedure Check_Class_Condition + (Cond : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id; + Is_Precondition : Boolean) + is + function Check_Entity (N : Node_Id) return Traverse_Result; + -- Check reference to formal of inherited operation or to primitive + -- operation of root type. + + ------------------ + -- Check_Entity -- + ------------------ + + function Check_Entity (N : Node_Id) return Traverse_Result is + New_E : Entity_Id; + Orig_E : Entity_Id; + + begin + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then + (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N))) + and then + (Nkind (Parent (N)) /= N_Attribute_Reference + or else Attribute_Name (Parent (N)) /= Name_Class) + then + -- These checks do not apply to dispatching calls within the + -- condition, but only to calls whose static tag is that of + -- the parent type. + + if Is_Subprogram (Entity (N)) + and then Nkind (Parent (N)) = N_Function_Call + and then Present (Controlling_Argument (Parent (N))) + then + return OK; + end if; + + -- Determine whether entity has a renaming + + Orig_E := Entity (N); + New_E := Get_Mapped_Entity (Orig_E); + + if Present (New_E) then + + -- AI12-0166: A precondition for a protected operation + -- cannot include an internal call to a protected function + -- of the type. In the case of an inherited condition for an + -- overriding operation, both the operation and the function + -- are given by primitive wrappers. + + if Is_Precondition + and then Ekind (New_E) = E_Function + and then Is_Primitive_Wrapper (New_E) + and then Is_Primitive_Wrapper (Subp) + and then Scope (Subp) = Scope (New_E) + then + Error_Msg_Node_2 := Wrapped_Entity (Subp); + Error_Msg_NE + ("internal call to& cannot appear in inherited " + & "precondition of protected operation&", + Subp, Wrapped_Entity (New_E)); + end if; + end if; + + -- Check that there are no calls left to abstract operations if + -- the current subprogram is not abstract. + + if Present (New_E) + and then Nkind (Parent (N)) = N_Function_Call + and then N = Name (Parent (N)) + then + if not Is_Abstract_Subprogram (Subp) + and then Is_Abstract_Subprogram (New_E) + then + Error_Msg_Sloc := Sloc (Current_Scope); + Error_Msg_Node_2 := Subp; + + if Comes_From_Source (Subp) then + Error_Msg_NE + ("cannot call abstract subprogram & in inherited " + & "condition for&#", Subp, New_E); + else + Error_Msg_NE + ("cannot call abstract subprogram & in inherited " + & "condition for inherited&#", Subp, New_E); + end if; + + -- In SPARK mode, report error on inherited condition for an + -- inherited operation if it contains a call to an overriding + -- operation, because this implies that the pre/postconditions + -- of the inherited operation have changed silently. + + elsif SPARK_Mode = On + and then Warn_On_Suspicious_Contract + and then Present (Alias (Subp)) + and then Present (New_E) + and then Comes_From_Source (New_E) + then + Error_Msg_N + ("cannot modify inherited condition (SPARK RM 6.1.1(1))", + Parent (Subp)); + Error_Msg_Sloc := Sloc (New_E); + Error_Msg_Node_2 := Subp; + Error_Msg_NE + ("\overriding of&# forces overriding of&", + Parent (Subp), New_E); + end if; + end if; + end if; + + return OK; + end Check_Entity; + + procedure Check_Condition_Entities is + new Traverse_Proc (Check_Entity); + + -- Start of processing for Check_Class_Condition + + begin + -- No check required if the subprograms match + + if Par_Subp = Subp then + return; + end if; + + Update_Primitives_Mapping (Par_Subp, Subp); + Map_Formals (Par_Subp, Subp); + Check_Condition_Entities (Cond); + end Check_Class_Condition; + ----------------------------- -- Create_Generic_Contract -- ----------------------------- @@ -1900,7 +2037,7 @@ package body Contracts is procedure Add_Stable_Property_Contracts (Subp_Id : Entity_Id; Class_Present : Boolean) is - Loc : constant Source_Ptr := Sloc (Subp_Id); + Loc : constant Source_Ptr := Sloc (Subp_Id); procedure Insert_Stable_Property_Check (Formal : Entity_Id; Property_Function : Entity_Id); @@ -2552,13 +2689,38 @@ package body Contracts is --------------------------------- procedure Process_Spec_Postconditions is - Subps : constant Subprogram_List := - Inherited_Subprograms (Spec_Id); + Subps : constant Subprogram_List := + Inherited_Subprograms (Spec_Id); + Seen : Subprogram_List (Subps'Range) := (others => Empty); + + function Seen_Subp (Subp_Id : Entity_Id) return Boolean; + -- Return True if the contract of subprogram Subp_Id has been + -- processed. + + --------------- + -- Seen_Subp -- + --------------- + + function Seen_Subp (Subp_Id : Entity_Id) return Boolean is + begin + for Index in Seen'Range loop + if Seen (Index) = Subp_Id then + return True; + end if; + end loop; + + return False; + end Seen_Subp; + + -- Local variables + Item : Node_Id; Items : Node_Id; Prag : Node_Id; Subp_Id : Entity_Id; + -- Start of processing for Process_Spec_Postconditions + begin -- Process the contract @@ -2589,7 +2751,7 @@ package body Contracts is Subp_Id := Ultimate_Alias (Subp_Id); end if; - -- Wrappers of class-wide pre/post conditions reference the + -- Wrappers of class-wide pre/postconditions reference the -- parent primitive that has the inherited contract. if Is_Wrapper (Subp_Id) @@ -2600,7 +2762,9 @@ package body Contracts is Items := Contract (Subp_Id); - if Present (Items) then + if not Seen_Subp (Subp_Id) and then Present (Items) then + Seen (Index) := Subp_Id; + Prag := Pre_Post_Conditions (Items); while Present (Prag) loop if Pragma_Name (Prag) = Name_Postcondition @@ -2657,10 +2821,6 @@ package body Contracts is --------------------------- procedure Process_Preconditions is - Class_Pre : Node_Id := Empty; - -- The sole [inherited] class-wide precondition pragma that applies - -- to the subprogram. - Insert_Node : Node_Id := Empty; -- The insertion node after which all pragma Check equivalents are -- inserted. @@ -2669,21 +2829,12 @@ package body Contracts is -- Determine whether arbitrary declaration Decl denotes a renaming of -- a discriminant or protection field _object. - procedure Merge_Preconditions (From : Node_Id; Into : Node_Id); - -- Merge two class-wide preconditions by "or else"-ing them. The - -- changes are accumulated in parameter Into. Update the error - -- message of Into. - procedure Prepend_To_Decls (Item : Node_Id); -- Prepend a single item to the declarations of the subprogram body - procedure Prepend_To_Decls_Or_Save (Prag : Node_Id); - -- Save a class-wide precondition into Class_Pre, or prepend a normal - -- precondition to the declarations of the body and analyze it. - - procedure Process_Inherited_Preconditions; - -- Collect all inherited class-wide preconditions and merge them into - -- one big precondition to be evaluated as pragma Check. + procedure Prepend_Pragma_To_Decls (Prag : Node_Id); + -- Prepend a normal precondition to the declarations of the body and + -- analyze it. procedure Process_Preconditions_For (Subp_Id : Entity_Id); -- Collect all preconditions of subprogram Subp_Id and prepend their @@ -2737,78 +2888,6 @@ package body Contracts is return False; end Is_Prologue_Renaming; - ------------------------- - -- Merge_Preconditions -- - ------------------------- - - procedure Merge_Preconditions (From : Node_Id; Into : Node_Id) is - function Expression_Arg (Prag : Node_Id) return Node_Id; - -- Return the boolean expression argument of a precondition while - -- updating its parentheses count for the subsequent merge. - - function Message_Arg (Prag : Node_Id) return Node_Id; - -- Return the message argument of a precondition - - -------------------- - -- Expression_Arg -- - -------------------- - - function Expression_Arg (Prag : Node_Id) return Node_Id is - Args : constant List_Id := Pragma_Argument_Associations (Prag); - Arg : constant Node_Id := Get_Pragma_Arg (Next (First (Args))); - - begin - if Paren_Count (Arg) = 0 then - Set_Paren_Count (Arg, 1); - end if; - - return Arg; - end Expression_Arg; - - ----------------- - -- Message_Arg -- - ----------------- - - function Message_Arg (Prag : Node_Id) return Node_Id is - Args : constant List_Id := Pragma_Argument_Associations (Prag); - begin - return Get_Pragma_Arg (Last (Args)); - end Message_Arg; - - -- Local variables - - From_Expr : constant Node_Id := Expression_Arg (From); - From_Msg : constant Node_Id := Message_Arg (From); - Into_Expr : constant Node_Id := Expression_Arg (Into); - Into_Msg : constant Node_Id := Message_Arg (Into); - Loc : constant Source_Ptr := Sloc (Into); - - -- Start of processing for Merge_Preconditions - - begin - -- Merge the two preconditions by "or else"-ing them - - Rewrite (Into_Expr, - Make_Or_Else (Loc, - Right_Opnd => Relocate_Node (Into_Expr), - Left_Opnd => From_Expr)); - - -- Merge the two error messages to produce a single message of the - -- form: - - -- failed precondition from ... - -- also failed inherited precondition from ... - - if not Exception_Locations_Suppressed then - Start_String (Strval (Into_Msg)); - Store_String_Char (ASCII.LF); - Store_String_Chars (" also "); - Store_String_Chars (Strval (From_Msg)); - - Set_Strval (Into_Msg, End_String); - end if; - end Merge_Preconditions; - ---------------------- -- Prepend_To_Decls -- ---------------------- @@ -2829,28 +2908,27 @@ package body Contracts is Prepend_To (Decls, Item); end Prepend_To_Decls; - ------------------------------ - -- Prepend_To_Decls_Or_Save -- - ------------------------------ + ----------------------------- + -- Prepend_Pragma_To_Decls -- + ----------------------------- - procedure Prepend_To_Decls_Or_Save (Prag : Node_Id) is + procedure Prepend_Pragma_To_Decls (Prag : Node_Id) is Check_Prag : Node_Id; begin - Check_Prag := Build_Pragma_Check_Equivalent (Prag); - - -- Save the sole class-wide precondition (if any) for the next - -- step, where it will be merged with inherited preconditions. + -- Skip the sole class-wide precondition (if any) since it is + -- processed by Merge_Class_Conditions. if Class_Present (Prag) then - pragma Assert (No (Class_Pre)); - Class_Pre := Check_Prag; + null; -- Accumulate the corresponding Check pragmas at the top of the -- declarations. Prepending the items ensures that they will be -- evaluated in their original order. else + Check_Prag := Build_Pragma_Check_Equivalent (Prag); + if Present (Insert_Node) then Insert_After (Insert_Node, Check_Prag); else @@ -2859,87 +2937,7 @@ package body Contracts is Analyze (Check_Prag); end if; - end Prepend_To_Decls_Or_Save; - - ------------------------------------- - -- Process_Inherited_Preconditions -- - ------------------------------------- - - procedure Process_Inherited_Preconditions is - Subps : constant Subprogram_List := - Inherited_Subprograms (Spec_Id); - - Item : Node_Id; - Items : Node_Id; - Prag : Node_Id; - Subp_Id : Entity_Id; - - begin - -- Process the contracts of all inherited subprograms, looking for - -- class-wide preconditions. - - for Index in Subps'Range loop - Subp_Id := Subps (Index); - - if Present (Alias (Subp_Id)) then - Subp_Id := Ultimate_Alias (Subp_Id); - end if; - - -- Wrappers of class-wide pre/post conditions reference the - -- parent primitive that has the inherited contract. - - if Is_Wrapper (Subp_Id) - and then Present (LSP_Subprogram (Subp_Id)) - then - Subp_Id := LSP_Subprogram (Subp_Id); - end if; - - Items := Contract (Subp_Id); - - if Present (Items) then - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Precondition - and then Class_Present (Prag) - then - Item := - Build_Pragma_Check_Equivalent - (Prag => Prag, - Subp_Id => Spec_Id, - Inher_Id => Subp_Id); - - -- The pragma Check equivalent of the class-wide - -- precondition is still created even though the - -- pragma may be ignored because the equivalent - -- performs semantic checks. - - if Is_Checked (Prag) then - - -- The spec of an inherited subprogram already - -- yielded a class-wide precondition. Merge the - -- existing precondition with the current one - -- using "or else". - - if Present (Class_Pre) then - Merge_Preconditions (Item, Class_Pre); - else - Class_Pre := Item; - end if; - end if; - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - end loop; - - -- Add the merged class-wide preconditions - - if Present (Class_Pre) then - Prepend_To_Decls (Class_Pre); - Analyze (Class_Pre); - end if; - end Process_Inherited_Preconditions; + end Prepend_Pragma_To_Decls; ------------------------------- -- Process_Preconditions_For -- @@ -2983,7 +2981,7 @@ package body Contracts is N => Body_Decl); end if; - Prepend_To_Decls_Or_Save (Prag); + Prepend_Pragma_To_Decls (Prag); end if; Prag := Next_Pragma (Prag); @@ -3008,7 +3006,7 @@ package body Contracts is if Pragma_Name (Decl) = Name_Precondition and then Is_Checked (Decl) then - Prepend_To_Decls_Or_Save (Decl); + Prepend_Pragma_To_Decls (Decl); end if; -- Skip internally generated code @@ -3073,22 +3071,21 @@ package body Contracts is Next (Decl); end loop; - end if; - -- The processing of preconditions is done in reverse order (body - -- first), because each pragma Check equivalent is inserted at the - -- top of the declarations. This ensures that the final order is - -- consistent with following diagram: + -- The processing of preconditions is done in reverse order (body + -- first), because each pragma Check equivalent is inserted at the + -- top of the declarations. This ensures that the final order is + -- consistent with following diagram: - -- <inherited preconditions> - -- <preconditions from spec> - -- <preconditions from body> + -- <inherited preconditions> + -- <preconditions from spec> + -- <preconditions from body> - Process_Preconditions_For (Body_Id); + Process_Preconditions_For (Body_Id); + end if; if Present (Spec_Id) then Process_Preconditions_For (Spec_Id); - Process_Inherited_Preconditions; end if; end Process_Preconditions; @@ -3139,6 +3136,12 @@ package body Contracts is elsif Is_Ignored_Ghost_Entity (Subp_Id) then return; + -- No action needed for helpers and indirect-call wrapper built to + -- support class-wide preconditions. + + elsif Present (Class_Preconditions_Subprogram (Subp_Id)) then + return; + -- Do not re-expand the same contract. This scenario occurs when a -- construct is rewritten into something else during its analysis -- (expression functions for instance). @@ -3440,7 +3443,7 @@ package body Contracts is -- Get_Postcond_Enabled -- -------------------------- - function Get_Postcond_Enabled (Subp : Entity_Id) return Node_Id is + function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id is Decl : Node_Id; begin Decl := @@ -3465,7 +3468,7 @@ package body Contracts is ------------------------------------ function Get_Result_Object_For_Postcond - (Subp : Entity_Id) return Node_Id + (Subp : Entity_Id) return Entity_Id is Decl : Node_Id; begin @@ -3490,7 +3493,7 @@ package body Contracts is -- Get_Return_Success_For_Postcond -- ------------------------------------- - function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Node_Id + function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Entity_Id is Decl : Node_Id; begin @@ -3605,6 +3608,1112 @@ package body Contracts is end if; end Instantiate_Subprogram_Contract; + ----------------------------------- + -- Make_Class_Precondition_Subps -- + ----------------------------------- + + procedure Make_Class_Precondition_Subps + (Subp_Id : Entity_Id; + Late_Overriding : Boolean := False) + is + Loc : constant Source_Ptr := Sloc (Subp_Id); + Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Subp_Id); + + procedure Add_Indirect_Call_Wrapper; + -- Build the indirect-call wrapper and append it to the freezing actions + -- of Tagged_Type. + + procedure Add_Call_Helper + (Helper_Id : Entity_Id; + Is_Dynamic : Boolean); + -- Factorizes code for building a call helper with the given identifier + -- and append it to the freezing actions of Tagged_Type. Is_Dynamic + -- controls building the static or dynamic version of the helper. + + ------------------------------- + -- Add_Indirect_Call_Wrapper -- + ------------------------------- + + procedure Add_Indirect_Call_Wrapper is + + function Build_ICW_Body return Node_Id; + -- Build the body of the indirect call wrapper + + function Build_ICW_Decl return Node_Id; + -- Build the declaration of the indirect call wrapper + + -------------------- + -- Build_ICW_Body -- + -------------------- + + function Build_ICW_Body return Node_Id is + ICW_Id : constant Entity_Id := Indirect_Call_Wrapper (Subp_Id); + Spec : constant Node_Id := Parent (ICW_Id); + Body_Spec : Node_Id; + Call : Node_Id; + ICW_Body : Node_Id; + + begin + Body_Spec := Copy_Subprogram_Spec (Spec); + + -- Build call to wrapped subprogram + + declare + Actuals : constant List_Id := Empty_List; + Formal_Spec : Entity_Id := + First (Parameter_Specifications (Spec)); + begin + -- Build parameter association & call + + while Present (Formal_Spec) loop + Append_To (Actuals, + New_Occurrence_Of + (Defining_Identifier (Formal_Spec), Loc)); + Next (Formal_Spec); + end loop; + + if Ekind (ICW_Id) = E_Procedure then + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Subp_Id, Loc), + Parameter_Associations => Actuals); + else + Call := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Subp_Id, Loc), + Parameter_Associations => Actuals)); + end if; + end; + + ICW_Body := + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call))); + + -- The new operation is internal and overriding indicators do not + -- apply. + + Set_Must_Override (Body_Spec, False); + + return ICW_Body; + end Build_ICW_Body; + + -------------------- + -- Build_ICW_Decl -- + -------------------- + + function Build_ICW_Decl return Node_Id is + ICW_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Subp_Id), + Suffix => "ICW", + Suffix_Index => Source_Offset (Loc))); + Decl : Node_Id; + Spec : Node_Id; + + begin + Spec := Copy_Subprogram_Spec (Parent (Subp_Id)); + Set_Must_Override (Spec, False); + Set_Must_Not_Override (Spec, False); + Set_Defining_Unit_Name (Spec, ICW_Id); + Mutate_Ekind (ICW_Id, Ekind (Subp_Id)); + Set_Is_Public (ICW_Id); + + -- The indirect call wrapper is commonly used for indirect calls + -- but inlined for direct calls performed from the DTW. + + Set_Is_Inlined (ICW_Id); + + if Nkind (Spec) = N_Procedure_Specification then + Set_Null_Present (Spec, False); + end if; + + Decl := Make_Subprogram_Declaration (Loc, Spec); + + -- Link original subprogram to indirect wrapper and vice versa + + Set_Indirect_Call_Wrapper (Subp_Id, ICW_Id); + Set_Class_Preconditions_Subprogram (ICW_Id, Subp_Id); + + -- Inherit debug info flag to allow debugging the wrapper + + if Needs_Debug_Info (Subp_Id) then + Set_Debug_Info_Needed (ICW_Id); + end if; + + return Decl; + end Build_ICW_Decl; + + -- Local Variables + + ICW_Body : Node_Id; + ICW_Decl : Node_Id; + + -- Start of processing for Add_Indirect_Call_Wrapper + + begin + pragma Assert (No (Indirect_Call_Wrapper (Subp_Id))); + + ICW_Decl := Build_ICW_Decl; + + Ensure_Freeze_Node (Tagged_Type); + Append_Freeze_Action (Tagged_Type, ICW_Decl); + Analyze (ICW_Decl); + + ICW_Body := Build_ICW_Body; + Append_Freeze_Action (Tagged_Type, ICW_Body); + + -- We cannot defer the analysis of this ICW wrapper when it is + -- built as a consequence of building its partner DTW wrapper + -- at the freezing point of the tagged type. + + if Is_Dispatch_Table_Wrapper (Subp_Id) then + Analyze (ICW_Body); + end if; + end Add_Indirect_Call_Wrapper; + + --------------------- + -- Add_Call_Helper -- + --------------------- + + procedure Add_Call_Helper + (Helper_Id : Entity_Id; + Is_Dynamic : Boolean) + is + function Build_Call_Helper_Body return Node_Id; + -- Build the body of a call helper + + function Build_Call_Helper_Decl return Node_Id; + -- Build the declaration of a call helper + + function Build_Call_Helper_Spec (Spec_Id : Entity_Id) return Node_Id; + -- Build the specification of the helper + + ---------------------------- + -- Build_Call_Helper_Body -- + ---------------------------- + + function Build_Call_Helper_Body return Node_Id is + + function Copy_And_Update_References + (Expr : Node_Id) return Node_Id; + -- Copy Expr updating references to formals of Helper_Id; update + -- also references to loop identifiers of quantified expressions. + + -------------------------------- + -- Copy_And_Update_References -- + -------------------------------- + + function Copy_And_Update_References + (Expr : Node_Id) return Node_Id + is + Assoc_List : constant Elist_Id := New_Elmt_List; + + procedure Map_Quantified_Expression_Loop_Identifiers; + -- Traverse Expr and append to Assoc_List the mapping of loop + -- identifers of quantified expressions with its new copy. + + ------------------------------------------------ + -- Map_Quantified_Expression_Loop_Identifiers -- + ------------------------------------------------ + + procedure Map_Quantified_Expression_Loop_Identifiers is + function Map_Loop_Param (N : Node_Id) return Traverse_Result; + -- Append to Assoc_List the mapping of loop identifers of + -- quantified expressions with its new copy. + + -------------------- + -- Map_Loop_Param -- + -------------------- + + function Map_Loop_Param (N : Node_Id) return Traverse_Result + is + begin + if Nkind (N) = N_Loop_Parameter_Specification + and then Nkind (Parent (N)) = N_Quantified_Expression + then + declare + Def_Id : constant Entity_Id := + Defining_Identifier (N); + begin + Append_Elmt (Def_Id, Assoc_List); + Append_Elmt (New_Copy (Def_Id), Assoc_List); + end; + end if; + + return OK; + end Map_Loop_Param; + + procedure Map_Quantified_Expressions is + new Traverse_Proc (Map_Loop_Param); + + begin + Map_Quantified_Expressions (Expr); + end Map_Quantified_Expression_Loop_Identifiers; + + -- Local variables + + Subp_Formal_Id : Entity_Id := First_Formal (Subp_Id); + Helper_Formal_Id : Entity_Id := First_Formal (Helper_Id); + + -- Start of processing for Copy_And_Update_References + + begin + while Present (Subp_Formal_Id) loop + Append_Elmt (Subp_Formal_Id, Assoc_List); + Append_Elmt (Helper_Formal_Id, Assoc_List); + + Next_Formal (Subp_Formal_Id); + Next_Formal (Helper_Formal_Id); + end loop; + + Map_Quantified_Expression_Loop_Identifiers; + + return New_Copy_Tree (Expr, Map => Assoc_List); + end Copy_And_Update_References; + + -- Local variables + + Helper_Decl : constant Node_Id := Parent (Parent (Helper_Id)); + Body_Id : Entity_Id; + Body_Spec : Node_Id; + Body_Stmts : Node_Id; + Helper_Body : Node_Id; + Return_Expr : Node_Id; + + -- Start of processing for Build_Call_Helper_Body + + begin + pragma Assert (Analyzed (Unit_Declaration_Node (Helper_Id))); + pragma Assert (No (Corresponding_Body (Helper_Decl))); + + Body_Id := Make_Defining_Identifier (Loc, Chars (Helper_Id)); + Body_Spec := Build_Call_Helper_Spec (Body_Id); + + Set_Corresponding_Body (Helper_Decl, Body_Id); + Set_Must_Override (Body_Spec, False); + + if Present (Class_Preconditions (Subp_Id)) then + Return_Expr := + Copy_And_Update_References (Class_Preconditions (Subp_Id)); + + -- When the subprogram is compiled with assertions disabled the + -- helper just returns True; done to avoid reporting errors at + -- link time since a unit may be compiled with assertions disabled + -- and another (which depends on it) compiled with assertions + -- enabled. + + else + pragma Assert (Present (Ignored_Class_Preconditions (Subp_Id))); + Return_Expr := New_Occurrence_Of (Standard_True, Loc); + end if; + + Body_Stmts := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, Return_Expr))); + + Helper_Body := + Make_Subprogram_Body (Loc, + Specification => Body_Spec, + Declarations => New_List, + Handled_Statement_Sequence => Body_Stmts); + + return Helper_Body; + end Build_Call_Helper_Body; + + ---------------------------- + -- Build_Call_Helper_Decl -- + ---------------------------- + + function Build_Call_Helper_Decl return Node_Id is + Decl : Node_Id; + Spec : Node_Id; + + begin + Spec := Build_Call_Helper_Spec (Helper_Id); + Set_Must_Override (Spec, False); + Set_Must_Not_Override (Spec, False); + Set_Is_Inlined (Helper_Id); + Set_Is_Public (Helper_Id); + + Decl := Make_Subprogram_Declaration (Loc, Spec); + + -- Inherit debug info flag from Subp_Id to Helper_Id to allow + -- debugging of the helper subprogram. + + if Needs_Debug_Info (Subp_Id) then + Set_Debug_Info_Needed (Helper_Id); + end if; + + return Decl; + end Build_Call_Helper_Decl; + + ---------------------------- + -- Build_Call_Helper_Spec -- + ---------------------------- + + function Build_Call_Helper_Spec (Spec_Id : Entity_Id) return Node_Id + is + Spec : constant Node_Id := Parent (Subp_Id); + Def_Id : constant Node_Id := Defining_Unit_Name (Spec); + Formal : Entity_Id; + Func_Formals : constant List_Id := New_List; + P_Spec : constant List_Id := Parameter_Specifications (Spec); + Par_Formal : Node_Id; + Param : Node_Id; + Param_Type : Node_Id; + + begin + -- Create a list of formal parameters with the same types as the + -- original subprogram but changing the controlling formal. + + Param := First (P_Spec); + Formal := First_Formal (Def_Id); + while Present (Formal) loop + Par_Formal := Parent (Formal); + + if Is_Dynamic and then Is_Controlling_Formal (Formal) then + if Nkind (Parameter_Type (Par_Formal)) + = N_Access_Definition + then + Param_Type := + Copy_Separate_Tree (Parameter_Type (Par_Formal)); + Rewrite (Subtype_Mark (Param_Type), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Subtype_Mark (Param_Type)), + Attribute_Name => Name_Class)); + + else + Param_Type := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Formal), Loc), + Attribute_Name => Name_Class); + end if; + else + Param_Type := New_Occurrence_Of (Etype (Formal), Loc); + end if; + + Append_To (Func_Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Formal)), + In_Present => In_Present (Par_Formal), + Out_Present => Out_Present (Par_Formal), + Null_Exclusion_Present => Null_Exclusion_Present + (Par_Formal), + Parameter_Type => Param_Type)); + + Next (Param); + Next_Formal (Formal); + end loop; + + return + Make_Function_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Func_Formals, + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + end Build_Call_Helper_Spec; + + -- Local variables + + Helper_Body : Node_Id; + Helper_Decl : Node_Id; + + -- Start of processing for Add_Call_Helper + + begin + Helper_Decl := Build_Call_Helper_Decl; + Mutate_Ekind (Helper_Id, Ekind (Subp_Id)); + + -- Add the helper to the freezing actions of the tagged type + + Ensure_Freeze_Node (Tagged_Type); + Append_Freeze_Action (Tagged_Type, Helper_Decl); + Analyze (Helper_Decl); + + Helper_Body := Build_Call_Helper_Body; + Append_Freeze_Action (Tagged_Type, Helper_Body); + + -- If this helper is built as part of building the DTW at the + -- freezing point of its tagged type then we cannot defer + -- its analysis. + + if Late_Overriding then + pragma Assert (Is_Dispatch_Table_Wrapper (Subp_Id)); + Analyze (Helper_Body); + end if; + end Add_Call_Helper; + + -- Local variables + + Helper_Id : Entity_Id; + + -- Start of processing for Make_Class_Precondition_Subps + + begin + if Present (Class_Preconditions (Subp_Id)) + or Present (Ignored_Class_Preconditions (Subp_Id)) + then + pragma Assert + (Comes_From_Source (Subp_Id) + or else Is_Dispatch_Table_Wrapper (Subp_Id)); + + if No (Dynamic_Call_Helper (Subp_Id)) then + + -- Build and add to the freezing actions of Tagged_Type its + -- dynamic-call helper. + + Helper_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Subp_Id), + Suffix => "DP", + Suffix_Index => Source_Offset (Loc))); + Add_Call_Helper (Helper_Id, Is_Dynamic => True); + + -- Link original subprogram to helper and vice versa + + Set_Dynamic_Call_Helper (Subp_Id, Helper_Id); + Set_Class_Preconditions_Subprogram (Helper_Id, Subp_Id); + end if; + + if not Is_Abstract_Subprogram (Subp_Id) + and then No (Static_Call_Helper (Subp_Id)) + then + -- Build and add to the freezing actions of Tagged_Type its + -- static-call helper. + + Helper_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Subp_Id), + Suffix => "SP", + Suffix_Index => Source_Offset (Loc))); + + Add_Call_Helper (Helper_Id, Is_Dynamic => False); + + -- Link original subprogram to helper and vice versa + + Set_Static_Call_Helper (Subp_Id, Helper_Id); + Set_Class_Preconditions_Subprogram (Helper_Id, Subp_Id); + + -- Build and add to the freezing actions of Tagged_Type the + -- indirect-call wrapper. + + Add_Indirect_Call_Wrapper; + end if; + end if; + end Make_Class_Precondition_Subps; + + ---------------------------------------------- + -- Process_Class_Conditions_At_Freeze_Point -- + ---------------------------------------------- + + procedure Process_Class_Conditions_At_Freeze_Point (Typ : Entity_Id) is + + procedure Check_Class_Conditions (Spec_Id : Entity_Id); + -- Check class-wide pre/postconditions of Spec_Id + + function Has_Class_Postconditions_Subprogram + (Spec_Id : Entity_Id) return Boolean; + -- Return True if Spec_Id has (or inherits) a postconditions subprogram. + + function Has_Class_Preconditions_Subprogram + (Spec_Id : Entity_Id) return Boolean; + -- Return True if Spec_Id has (or inherits) a preconditions subprogram. + + ---------------------------- + -- Check_Class_Conditions -- + ---------------------------- + + procedure Check_Class_Conditions (Spec_Id : Entity_Id) is + Par_Subp : Entity_Id; + + begin + for Kind in Condition_Kind loop + Par_Subp := Nearest_Class_Condition_Subprogram (Kind, Spec_Id); + + if Present (Par_Subp) then + Check_Class_Condition + (Cond => Class_Condition (Kind, Par_Subp), + Subp => Spec_Id, + Par_Subp => Par_Subp, + Is_Precondition => Kind in Ignored_Class_Precondition + | Class_Precondition); + end if; + end loop; + end Check_Class_Conditions; + + ----------------------------------------- + -- Has_Class_Postconditions_Subprogram -- + ----------------------------------------- + + function Has_Class_Postconditions_Subprogram + (Spec_Id : Entity_Id) return Boolean is + begin + return + Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Spec_Id, + Kind => Class_Postcondition)) + or else + Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Spec_Id, + Kind => Ignored_Class_Postcondition)); + end Has_Class_Postconditions_Subprogram; + + ---------------------------------------- + -- Has_Class_Preconditions_Subprogram -- + ---------------------------------------- + + function Has_Class_Preconditions_Subprogram + (Spec_Id : Entity_Id) return Boolean is + begin + return + Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Spec_Id, + Kind => Class_Precondition)) + or else + Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Spec_Id, + Kind => Ignored_Class_Precondition)); + end Has_Class_Preconditions_Subprogram; + + -- Local variables + + Prim_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ)); + Prim : Entity_Id; + + -- Start of processing for Process_Class_Conditions_At_Freeze_Point + + begin + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + if Has_Class_Preconditions_Subprogram (Prim) + or else Has_Class_Postconditions_Subprogram (Prim) + then + if Comes_From_Source (Prim) then + if Has_Significant_Contract (Prim) then + Merge_Class_Conditions (Prim); + end if; + + -- Handle wrapper of protected operation + + elsif Is_Primitive_Wrapper (Prim) then + Merge_Class_Conditions (Prim); + + -- Check inherited class-wide conditions, excluding internal + -- entities built for mapping of interface primitives. + + elsif Is_Derived_Type (Typ) + and then Present (Alias (Prim)) + and then No (Interface_Alias (Prim)) + then + Check_Class_Conditions (Prim); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Process_Class_Conditions_At_Freeze_Point; + + ---------------------------- + -- Merge_Class_Conditions -- + ---------------------------- + + procedure Merge_Class_Conditions (Spec_Id : Entity_Id) is + + procedure Preanalyze_Condition + (Subp : Entity_Id; + Expr : Node_Id); + -- Preanalyze the class-wide condition Expr of Subp + + procedure Process_Inherited_Conditions (Kind : Condition_Kind); + -- Collect all inherited class-wide conditions of Spec_Id and merge + -- them into one big condition. + + -------------------------- + -- Preanalyze_Condition -- + -------------------------- + + procedure Preanalyze_Condition + (Subp : Entity_Id; + Expr : Node_Id) + is + procedure Clear_Unset_References; + -- Clear unset references on formals of Subp since preanalysis + -- occurs in a place unrelated to the actual code. + + procedure Remove_Controlling_Arguments; + -- Traverse Expr and clear the Controlling_Argument of calls to + -- nonabstract functions. + + procedure Remove_Formals (Id : Entity_Id); + -- Remove formals from homonym chains and make them not visible + + ---------------------------- + -- Clear_Unset_References -- + ---------------------------- + + procedure Clear_Unset_References is + F : Entity_Id := First_Formal (Subp); + + begin + while Present (F) loop + Set_Unset_Reference (F, Empty); + Next_Formal (F); + end loop; + end Clear_Unset_References; + + ---------------------------------- + -- Remove_Controlling_Arguments -- + ---------------------------------- + + procedure Remove_Controlling_Arguments is + function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result; + -- Reset the Controlling_Argument of calls to nonabstract + -- function calls. + + --------------------- + -- Remove_Ctrl_Arg -- + --------------------- + + function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Function_Call + and then Present (Controlling_Argument (N)) + and then not Is_Abstract_Subprogram (Entity (Name (N))) + then + Set_Controlling_Argument (N, Empty); + end if; + + return OK; + end Remove_Ctrl_Arg; + + procedure Remove_Ctrl_Args is new Traverse_Proc (Remove_Ctrl_Arg); + begin + Remove_Ctrl_Args (Expr); + end Remove_Controlling_Arguments; + + -------------------- + -- Remove_Formals -- + -------------------- + + procedure Remove_Formals (Id : Entity_Id) is + F : Entity_Id := First_Formal (Id); + + begin + while Present (F) loop + Set_Is_Immediately_Visible (F, False); + Remove_Homonym (F); + Next_Formal (F); + end loop; + end Remove_Formals; + + -- Start of processing for Preanalyze_Condition + + begin + pragma Assert (Present (Expr)); + pragma Assert (Inside_Class_Condition_Preanalysis = False); + + Push_Scope (Subp); + Install_Formals (Subp); + Inside_Class_Condition_Preanalysis := True; + + Preanalyze_And_Resolve (Expr, Standard_Boolean); + + Inside_Class_Condition_Preanalysis := False; + Remove_Formals (Subp); + Pop_Scope; + + -- Traverse Expr and clear the Controlling_Argument of calls to + -- nonabstract functions. Required since the preanalyzed condition + -- is not yet installed on its definite context and will be cloned + -- and extended in derivations with additional conditions. + + Remove_Controlling_Arguments; + + -- Clear also attribute Unset_Reference; again because preanalysis + -- occurs in a place unrelated to the actual code. + + Clear_Unset_References; + end Preanalyze_Condition; + + ---------------------------------- + -- Process_Inherited_Conditions -- + ---------------------------------- + + procedure Process_Inherited_Conditions (Kind : Condition_Kind) is + Tag_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id); + Subps : constant Subprogram_List := Inherited_Subprograms (Spec_Id); + Seen : Subprogram_List (Subps'Range) := (others => Empty); + + function Inherit_Condition + (Par_Subp : Entity_Id; + Subp : Entity_Id) return Node_Id; + -- Inherit the class-wide condition from Par_Subp to Subp and adjust + -- all the references to formals in the inherited condition. + + procedure Merge_Conditions (From : Node_Id; Into : Node_Id); + -- Merge two class-wide preconditions or postconditions (the former + -- are merged using "or else", and the latter are merged using "and- + -- then"). The changes are accumulated in parameter Into. + + function Seen_Subp (Id : Entity_Id) return Boolean; + -- Return True if the contract of subprogram Id has been processed + + ----------------------- + -- Inherit_Condition -- + ----------------------- + + function Inherit_Condition + (Par_Subp : Entity_Id; + Subp : Entity_Id) return Node_Id + is + Installed_Calls : constant Elist_Id := New_Elmt_List; + + procedure Install_Original_Selected_Component (Expr : Node_Id); + -- Traverse the given expression searching for dispatching calls + -- to functions whose original nodes was a selected component, + -- and replacing them temporarily by a copy of their original + -- node. Modified calls are stored in the list Installed_Calls + -- (to undo this work later). + + procedure Restore_Dispatching_Calls (Expr : Node_Id); + -- Undo the work done by Install_Original_Selected_Component. + + ----------------------------------------- + -- Install_Original_Selected_Component -- + ----------------------------------------- + + procedure Install_Original_Selected_Component (Expr : Node_Id) is + function Install_Node (N : Node_Id) return Traverse_Result; + -- Process a single node + + ------------------ + -- Install_Node -- + ------------------ + + function Install_Node (N : Node_Id) return Traverse_Result is + New_N : Node_Id; + Orig_Nod : Node_Id; + + begin + if Nkind (N) = N_Function_Call + and then Nkind (Original_Node (N)) = N_Selected_Component + and then Is_Dispatching_Operation (Entity (Name (N))) + then + Orig_Nod := Original_Node (N); + + -- Temporarily use the original node field to keep the + -- reference to this node (to undo this work later!). + + New_N := New_Copy (N); + Set_Original_Node (New_N, Orig_Nod); + Append_Elmt (New_N, Installed_Calls); + + Rewrite (N, Orig_Nod); + Set_Original_Node (N, New_N); + end if; + + return OK; + end Install_Node; + + procedure Install_Nodes is new Traverse_Proc (Install_Node); + + begin + Install_Nodes (Expr); + end Install_Original_Selected_Component; + + ------------------------------- + -- Restore_Dispatching_Calls -- + ------------------------------- + + procedure Restore_Dispatching_Calls (Expr : Node_Id) is + function Restore_Node (N : Node_Id) return Traverse_Result; + -- Process a single node + + ------------------ + -- Restore_Node -- + ------------------ + + function Restore_Node (N : Node_Id) return Traverse_Result is + Orig_Sel_N : Node_Id; + + begin + if Nkind (N) = N_Selected_Component + and then Nkind (Original_Node (N)) = N_Function_Call + and then Contains (Installed_Calls, Original_Node (N)) + then + Orig_Sel_N := Original_Node (Original_Node (N)); + pragma Assert (Nkind (Orig_Sel_N) = N_Selected_Component); + Rewrite (N, Original_Node (N)); + Set_Original_Node (N, Orig_Sel_N); + end if; + + return OK; + end Restore_Node; + + procedure Restore_Nodes is new Traverse_Proc (Restore_Node); + + begin + Restore_Nodes (Expr); + end Restore_Dispatching_Calls; + + -- Local variables + + Assoc_List : constant Elist_Id := New_Elmt_List; + Par_Formal_Id : Entity_Id := First_Formal (Par_Subp); + Subp_Formal_Id : Entity_Id := First_Formal (Subp); + New_Expr : Node_Id; + Class_Cond : Node_Id; + + -- Start of processing for Inherit_Condition + + begin + while Present (Par_Formal_Id) loop + Append_Elmt (Par_Formal_Id, Assoc_List); + Append_Elmt (Subp_Formal_Id, Assoc_List); + + Next_Formal (Par_Formal_Id); + Next_Formal (Subp_Formal_Id); + end loop; + + -- In order to properly preanalyze an inherited preanalyzed + -- condition that has occurrences of the Object.Operation + -- notation we must restore the original node; otherwise we + -- would report spurious errors. + + Class_Cond := Class_Condition (Kind, Par_Subp); + + Install_Original_Selected_Component (Class_Cond); + New_Expr := New_Copy_Tree (Class_Cond); + Restore_Dispatching_Calls (Class_Cond); + + return New_Copy_Tree (New_Expr, Map => Assoc_List); + end Inherit_Condition; + + ---------------------- + -- Merge_Conditions -- + ---------------------- + + procedure Merge_Conditions (From : Node_Id; Into : Node_Id) is + function Expression_Arg (Expr : Node_Id) return Node_Id; + -- Return the boolean expression argument of a condition while + -- updating its parentheses count for the subsequent merge. + + -------------------- + -- Expression_Arg -- + -------------------- + + function Expression_Arg (Expr : Node_Id) return Node_Id is + begin + if Paren_Count (Expr) = 0 then + Set_Paren_Count (Expr, 1); + end if; + + return Expr; + end Expression_Arg; + + -- Local variables + + From_Expr : constant Node_Id := Expression_Arg (From); + Into_Expr : constant Node_Id := Expression_Arg (Into); + Loc : constant Source_Ptr := Sloc (Into); + + -- Start of processing for Merge_Conditions + + begin + case Kind is + + -- Merge the two preconditions by "or else"-ing them + + when Ignored_Class_Precondition + | Class_Precondition + => + Rewrite (Into_Expr, + Make_Or_Else (Loc, + Right_Opnd => Relocate_Node (Into_Expr), + Left_Opnd => From_Expr)); + + -- Merge the two postconditions by "and then"-ing them + + when Ignored_Class_Postcondition + | Class_Postcondition + => + Rewrite (Into_Expr, + Make_And_Then (Loc, + Right_Opnd => Relocate_Node (Into_Expr), + Left_Opnd => From_Expr)); + end case; + end Merge_Conditions; + + --------------- + -- Seen_Subp -- + --------------- + + function Seen_Subp (Id : Entity_Id) return Boolean is + begin + for Index in Seen'Range loop + if Seen (Index) = Id then + return True; + end if; + end loop; + + return False; + end Seen_Subp; + + -- Local variables + + Class_Cond : Node_Id; + Cond : Node_Id; + Subp_Id : Entity_Id; + Par_Prim : Entity_Id := Empty; + Par_Iface_Prims : Elist_Id := No_Elist; + + -- Start of processing for Process_Inherited_Conditions + + begin + Class_Cond := Class_Condition (Kind, Spec_Id); + + -- Process parent primitives looking for nearest ancestor with + -- class-wide conditions. + + for Index in Subps'Range loop + Subp_Id := Subps (Index); + + if No (Par_Prim) + and then Is_Ancestor (Find_Dispatching_Type (Subp_Id), Tag_Typ) + then + if Present (Alias (Subp_Id)) then + Subp_Id := Ultimate_Alias (Subp_Id); + end if; + + -- Wrappers of class-wide pre/postconditions reference the + -- parent primitive that has the inherited contract and help + -- us to climb fast. + + if Is_Wrapper (Subp_Id) + and then Present (LSP_Subprogram (Subp_Id)) + then + Subp_Id := LSP_Subprogram (Subp_Id); + end if; + + if not Seen_Subp (Subp_Id) + and then Present (Class_Condition (Kind, Subp_Id)) + then + Seen (Index) := Subp_Id; + Par_Prim := Subp_Id; + Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim); + + Cond := Inherit_Condition + (Subp => Spec_Id, + Par_Subp => Subp_Id); + + if Present (Class_Cond) then + Merge_Conditions (Cond, Class_Cond); + else + Class_Cond := Cond; + end if; + + Check_Class_Condition + (Cond => Class_Cond, + Subp => Spec_Id, + Par_Subp => Subp_Id, + Is_Precondition => Kind in Ignored_Class_Precondition + | Class_Precondition); + Build_Class_Wide_Expression + (Pragma_Or_Expr => Class_Cond, + Subp => Spec_Id, + Par_Subp => Subp_Id, + Adjust_Sloc => False); + + -- We are done as soon as we process the nearest ancestor + + exit; + end if; + end if; + end loop; + + -- Process the contract of interface primitives not covered by + -- the nearest ancestor. + + for Index in Subps'Range loop + Subp_Id := Subps (Index); + + if Is_Interface (Find_Dispatching_Type (Subp_Id)) then + if Present (Alias (Subp_Id)) then + Subp_Id := Ultimate_Alias (Subp_Id); + end if; + + if not Seen_Subp (Subp_Id) + and then Present (Class_Condition (Kind, Subp_Id)) + and then not Contains (Par_Iface_Prims, Subp_Id) + then + Seen (Index) := Subp_Id; + + Cond := Inherit_Condition + (Subp => Spec_Id, + Par_Subp => Subp_Id); + + Check_Class_Condition + (Cond => Cond, + Subp => Spec_Id, + Par_Subp => Subp_Id, + Is_Precondition => Kind in Ignored_Class_Precondition + | Class_Precondition); + Build_Class_Wide_Expression + (Pragma_Or_Expr => Cond, + Subp => Spec_Id, + Par_Subp => Subp_Id, + Adjust_Sloc => False); + + if Present (Class_Cond) then + Merge_Conditions (Cond, Class_Cond); + else + Class_Cond := Cond; + end if; + end if; + end if; + end loop; + + Set_Class_Condition (Kind, Spec_Id, Class_Cond); + end Process_Inherited_Conditions; + + -- Local variables + + Cond : Node_Id; + + -- Start of processing for Merge_Class_Conditions + + begin + for Kind in Condition_Kind loop + Cond := Class_Condition (Kind, Spec_Id); + + -- If this subprogram has class-wide conditions then preanalyze + -- them before processing inherited conditions since conditions + -- are checked and merged from right to left. + + if Present (Cond) then + Preanalyze_Condition (Spec_Id, Cond); + end if; + + Process_Inherited_Conditions (Kind); + + -- Preanalyze merged inherited conditions + + if Cond /= Class_Condition (Kind, Spec_Id) then + Preanalyze_Condition (Spec_Id, + Class_Condition (Kind, Spec_Id)); + end if; + end loop; + end Merge_Class_Conditions; + ---------------------------------------- -- Save_Global_References_In_Contract -- ---------------------------------------- @@ -3622,10 +4731,9 @@ package body Contracts is ------------------------------------ procedure Save_Global_References_In_List (First_Prag : Node_Id) is - Prag : Node_Id; + Prag : Node_Id := First_Prag; begin - Prag := First_Prag; while Present (Prag) loop if Is_Generic_Contract_Pragma (Prag) then Save_Global_References (Prag); @@ -3662,4 +4770,29 @@ package body Contracts is Pop_Scope; end Save_Global_References_In_Contract; + ------------------------- + -- Set_Class_Condition -- + ------------------------- + + procedure Set_Class_Condition + (Kind : Condition_Kind; + Subp : Entity_Id; + Cond : Node_Id) + is + begin + case Kind is + when Class_Postcondition => + Set_Class_Postconditions (Subp, Cond); + + when Class_Precondition => + Set_Class_Preconditions (Subp, Cond); + + when Ignored_Class_Postcondition => + Set_Ignored_Class_Postconditions (Subp, Cond); + + when Ignored_Class_Precondition => + Set_Ignored_Class_Preconditions (Subp, Cond); + end case; + end Set_Class_Condition; + end Contracts; diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads index bfd482e..eb26ebf 100644 --- a/gcc/ada/contracts.ads +++ b/gcc/ada/contracts.ads @@ -216,6 +216,31 @@ package Contracts is -- subprogram declaration template denoted by Templ. The instantiated -- pragmas are added to list L. + procedure Make_Class_Precondition_Subps + (Subp_Id : Entity_Id; + Late_Overriding : Boolean := False); + -- Build helpers that at run time evaluate statically and dynamically the + -- class-wide preconditions of Subp_Id; build also the indirect-call + -- wrapper (ICW) required to check class-wide preconditions when the + -- subprogram is invoked through an access-to-subprogram, or when it + -- overrides an inherited class-wide precondition (see AI12-0195-1). + -- Late_Overriding enables special handling required for late-overriding + -- subprograms. + + procedure Merge_Class_Conditions (Spec_Id : Entity_Id); + -- Merge and preanalyze all class-wide conditions of Spec_Id (class-wide + -- preconditions merged with operator or-else; class-wide postconditions + -- merged with operator and-then). Ignored pre/postconditions are also + -- merged since, although they are not required to generate code, their + -- preanalysis is required to perform semantic checks. Resulting merged + -- expressions are later installed by the expander in helper subprograms + -- which are invoked from the caller side; they are also used to build + -- the dispatch-table wrapper (DTW), if required. + + procedure Process_Class_Conditions_At_Freeze_Point (Typ : Entity_Id); + -- Merge, preanalyze, and check class-wide pre/postconditions of Typ + -- primitives. + procedure Save_Global_References_In_Contract (Templ : Node_Id; Gen_Id : Entity_Id); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 5245feb3..8873000 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -112,7 +112,7 @@ 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 Enable statistics printing in Atree -- 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 @@ -158,7 +158,7 @@ package body Debug is -- d_q -- d_r -- d_s Stop elaboration checks on synchronous suspension - -- d_t + -- d_t In LLVM-based CCG, dump LLVM IR after transformations are done -- d_u -- d_v Enable additional checks and debug printouts in Atree -- d_w @@ -210,7 +210,7 @@ package body Debug is -- d.5 Do not generate imported subprogram definitions in C code -- d.6 Do not avoid declaring unreferenced types in C code -- d.7 Disable unsound heuristics in gnat2scil (for CP as SPARK prover) - -- d.8 + -- d.8 Disable unconditional inlining of expression functions -- d.9 Disable build-in-place for nonlimited types -- d_1 @@ -830,6 +830,11 @@ 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 Enable statistics printing in Atree. First set Statistics_Enabled + -- in gen_il-gen.adb to True, then rebuild, then run the compiler + -- with -gnatd.A. You might want to apply "sort -nr" to parts of the + -- output. + -- 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 @@ -992,6 +997,10 @@ package body Debug is -- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True -- or Ada.Synchronous_Barriers.Wait_For_Release. + -- d_t In the LLVM-based CCG, do an additional dump of the LLVM IR + -- after the pass that does transformations to the IR into a + -- filename ending with .trans.ll. + -- d_v Enable additional checks and debug printouts in Atree -- d_x The compiler does not expand in line the Image attribute for user- @@ -1101,6 +1110,10 @@ package body Debug is -- issues (e.g., assuming that a low bound of an array parameter -- of an unconstrained subtype belongs to the index subtype). + -- d.8 By default calls to expression functions are always inlined. + -- This debug flag turns off this behavior, making them subject + -- to the usual inlining heuristics of the code generator. + -- d.9 Disable build-in-place for function calls returning nonlimited -- types. diff --git a/gcc/ada/doc/gnat_rm.rst b/gcc/ada/doc/gnat_rm.rst index 97f7e4d..7743ef8 100644 --- a/gcc/ada/doc/gnat_rm.rst +++ b/gcc/ada/doc/gnat_rm.rst @@ -55,6 +55,7 @@ GNAT Reference Manual gnat_rm/specialized_needs_annexes gnat_rm/implementation_of_specific_ada_features gnat_rm/implementation_of_ada_2012_features + gnat_rm/security_hardening_features gnat_rm/obsolescent_features gnat_rm/compatibility_and_porting_guide diff --git a/gcc/ada/doc/gnat_rm/about_this_guide.rst b/gcc/ada/doc/gnat_rm/about_this_guide.rst index b48785ee..9defee8 100644 --- a/gcc/ada/doc/gnat_rm/about_this_guide.rst +++ b/gcc/ada/doc/gnat_rm/about_this_guide.rst @@ -96,6 +96,9 @@ This reference manual contains the following chapters: * :ref:`Implementation_of_Ada_2012_Features`, describes the status of the GNAT implementation of the Ada 2012 language standard. +* :ref:`Security_Hardening_Features` documents GNAT extensions aimed + at security hardening. + * :ref:`Obsolescent_Features` documents implementation dependent features, including pragmas and attributes, which are considered obsolescent, since there are other preferred ways of achieving the same results. These diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst index 8d0be38..c5c7dfb 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst @@ -53,7 +53,8 @@ Any *code_statement* can potentially cause external interactions. See separate section on source representation. * - "The control functions allowed in comments. See 2.1(14)." + "The semantics of an Ada program whose text is not in + Normalization Form C. See 2.1(4)." See separate section on source representation. @@ -86,14 +87,14 @@ parameter, checks that the optimization flag is set, and aborts if it is not. * - "The sequence of characters of the value returned by - ``S'Image`` when some of the graphic characters of - ``S'Wide_Image`` are not defined in ``Character``. See - 3.5(37)." + "The message string associated with the Assertion_Error exception raised + by the failure of a predicate check if there is no applicable + Predicate_Failure aspect. See 3.2.4(31)." -The sequence of characters is as defined by the wide character encoding -method used for the source. See section on source representation for -further details. +In the case of a Dynamic_Predicate aspect, the string is +"Dynamic_Predicate failed at <source position>", where +"<source position>" might be something like "foo.adb:123". +The Static_Predicate case is handled analogously. * "The predefined integer types declared in @@ -146,12 +147,12 @@ Type Representation IEEE 80-bit Extended on x86 architecture ====================== =============================================== -The default rounding mode specified by the IEEE 754 Standard is assumed for -static computations, i.e. round to nearest, ties to even. The input routines -yield correctly rounded values for Short_Float, Float and Long_Float at least. -The output routines can compute up to twice as many exact digits as the value -of ``T'Digits`` for any type, for example 30 digits for Long_Float; if more -digits are requested, zeros are printed. +The default rounding mode specified by the IEEE 754 Standard is assumed both +for static and dynamic computations (that is, round to nearest, ties to even). +The input routines yield correctly rounded values for Short_Float, Float, and +Long_Float at least. The output routines can compute up to twice as many exact +digits as the value of ``T'Digits`` for any type, for example 30 digits for +Long_Float; if more digits are requested, zeros are printed. * "The small of an ordinary fixed point type. See 3.5.9(8)." @@ -192,24 +193,79 @@ Block numbers of the form :samp:`B{nnn}`, where *nnn* is a decimal integer are allocated. * + "The sequence of characters of the value returned by Tags.Expanded_Name + (respectively, Tags.Wide_Expanded_Name) when some of the graphic + characters of Tags.Wide_Wide_Expanded_Name are not defined in Character + (respectively, Wide_Character). See 3.9(10.1)." + +This is handled in the same way as the implementation-defined behavior +referenced in A.4.12(34). + +* "Implementation-defined attributes. See 4.1.4(12)." See :ref:`Implementation_Defined_Attributes`. * + "The value of the parameter to Empty for some container aggregates. + See 4.3.5(40)." + +As per the suggestion given in the Annotated Ada RM, the default value +of the formal parameter is used if one exists and zero is used otherwise. + +* + "The maximum number of chunks for a parallel reduction expression without + a chunk_specification. See 4.5.10(21)." + +Feature unimplemented. + +* + "Rounding of real static expressions which are exactly half-way between + two machine numbers. See 4.9(38)." + +Round to even is used in all such cases. + +* + "The maximum number of chunks for a parallel generalized iterator without + a chunk_specification. See 5.5.2(10)." + +Feature unimplemented. + +* + "The number of chunks for an array component iterator. See 5.5.2(11)." + +Feature unimplemented. + +* + "Any extensions of the Global aspect. See 6.1.2(43)." + +Feature unimplemented. + +* + "The circumstances the implementation passes in the null value for a view + conversion of an access type used as an out parameter. See 6.4.1(19)." + +Difficult to characterize. + +* + "Any extensions of the Default_Initial_Condition aspect. See 7.3.3(11)." + +SPARK allows specifying *null* as the Default_Initial_Condition +aspect of a type. See the SPARK reference manual for further details. + +* "Any implementation-defined time types. See 9.6(6)." There are no implementation-defined time types. * - "The time base associated with relative delays." + "The time base associated with relative delays. See 9.6(20)." See 9.6(20). The time base used is that provided by the C library function ``gettimeofday``. * - "The time base of the type ``Calendar.Time``. See - 9.6(23)." + "The time base of the type ``Calendar.Time``. See 9.6(23)." The time base used is that provided by the C library function ``gettimeofday``. @@ -229,13 +285,15 @@ setting for local time, as accessed by the C library function There are no such limits. * - "Whether or not two non-overlapping parts of a composite - object are independently addressable, in the case where packing, record - layout, or ``Component_Size`` is specified for the object. See - 9.10(1)." + "The result of Calendar.Formatting.Image if its argument represents more + than 100 hours. See 9.6.1(86)." + +Calendar.Time_Error is raised. + +* + "Implementation-defined conflict check policies. See 9.10.1(5)." -Separate components are independently addressable if they do not share -overlapping storage units. +There are no implementation-defined conflict check policies. * "The representation for a compilation. See 10.1(2)." @@ -281,9 +339,8 @@ options, refer to *GNAT Make Program gnatmake* in the :title:`GNAT User's Guide`. * - "The implementation-defined means, if any, of specifying - which compilation units are needed by a given compilation unit. See - 10.2(2)." + "The implementation-defined means, if any, of specifying which compilation + units are needed by a given compilation unit. See 10.2(2)." The units needed by a given compilation unit are as defined in the Ada Reference Manual section 10.2(2-6). There are no @@ -298,17 +355,13 @@ The main program is designated by providing the name of the corresponding :file:`ALI` file as the input parameter to the binder. * - "The order of elaboration of *library_items*. See - 10.2(18)." + "The order of elaboration of *library_items*. See 10.2(18)." The first constraint on ordering is that it meets the requirements of Chapter 10 of the Ada Reference Manual. This still leaves some -implementation dependent choices, which are resolved by first -elaborating bodies as early as possible (i.e., in preference to specs -where there is a choice), and second by evaluating the immediate with -clauses of a unit to determine the probably best choice, and -third by elaborating in alphabetical order of unit names -where a choice still remains. +implementation-dependent choices, which are resolved by analyzing +the elaboration code of each unit and identifying implicit +elaboration-order dependencies. * "Parameter passing and function return for the main @@ -320,13 +373,12 @@ value is the return code of the program (overriding any value that may have been set by a call to ``Ada.Command_Line.Set_Exit_Status``). * - "The mechanisms for building and running partitions. See - 10.2(24)." + "The mechanisms for building and running partitions. See 10.2(24)." -GNAT itself supports programs with only a single partition. The GNATDIST +GNAT itself supports programs with only a single partition. The GNATDIST tool provided with the GLADE package (which also includes an implementation of the PCS) provides a completely flexible method for building and running -programs consisting of multiple partitions. See the separate GLADE manual +programs consisting of multiple partitions. See the separate GLADE manual for details. * @@ -340,12 +392,11 @@ See separate section on compilation model. implementation. See 10.2(28)." Passive partitions are supported on targets where shared memory is -provided by the operating system. See the GLADE reference manual for +provided by the operating system. See the GLADE reference manual for further details. * - "The information returned by ``Exception_Message``. See - 11.4.1(10)." + "The information returned by ``Exception_Message``. See 11.4.1(10)." Exception message returns the null string unless a specific message has been passed by the program. @@ -391,6 +442,38 @@ where the last line is a single ``LF`` character (``16#0A#``). * + "The sequence of characters of the value returned by + Exceptions.Exception_Name (respectively, Exceptions.Wide_Exception_Name) + when some of the graphic characters of Exceptions.Wide_Wide_Exception_Name + are not defined in Character (respectively, Wide_Character). + See 11.4.1(12.1)." + +This is handled in the same way as the implementation-defined behavior +referenced in A.4.12(34). + +* + "The information returned by Exception_Information. See 11.4.1(13)." + +The exception name and the source location at which the exception was +raised are included. + +* + "Implementation-defined policy_identifiers and assertion_aspect_marks + allowed in a pragma Assertion_Policy. See 11.4.2(9)." + +Implementation-defined assertion_aspect_marks include Assert_And_Cut, +Assume, Contract_Cases, Debug, Ghost, Initial_Condition, Loop_Invariant, +Loop_Variant, Postcondition, Precondition, Predicate, Refined_Post, +Statement_Assertions, and Subprogram_Variant. Implementation-defined +policy_identifiers include Ignore and Suppressible. + +* + "The default assertion policy. See 11.4.2(10)." + +The default assertion policy is Ignore, although this can be overridden +via compiler switches such as "-gnata". + +* "Implementation-defined check names. See 11.5(27)." The implementation defined check names include Alignment_Check, @@ -400,28 +483,54 @@ program can add implementation-defined check names by means of the pragma Check_Name. See the description of pragma ``Suppress`` for full details. * - "The interpretation of each aspect of representation. See - 13.1(20)." + "Existence and meaning of second parameter of pragma Unsuppress. + See 11.5(27.1)." + +The legality rules for and semantics of the second parameter of pragma +Unsuppress match those for the second argument of pragma Suppress. + +* + "The cases that cause conflicts between the representation of the + ancestors of a type_declaration. See 13.1(13.1)." + +No such cases exist. + +* + "The interpretation of each representation aspect. See 13.1(20)." See separate section on data representations. * - "Any restrictions placed upon representation items. See - 13.1(20)." + "Any restrictions placed upon the specification of representation aspects. + See 13.1(20)." See separate section on data representations. * - "The meaning of ``Size`` for indefinite subtypes. See - 13.3(48)." + "Implementation-defined aspects, including the syntax for specifying + such aspects and the legality rules for such aspects. See 13.1.1(38)." + +See :ref:`Implementation_Defined_Aspects`. + +* + "The set of machine scalars. See 13.3(8.1)." + +See separate section on data representations. + +* + "The meaning of ``Size`` for indefinite subtypes. See 13.3(48)." + +The Size attribute of an indefinite subtype is not less than the Size +attribute of any object of that type. + +* + "The meaning of Object_Size for indefinite subtypes. See 13.3(58)." -Size for an indefinite subtype is the maximum possible size, except that -for the case of a subprogram parameter, the size of the parameter object -is the actual size. +The Object_Size attribute of an indefinite subtype is not less than the +Object_Size attribute of any object of that type. * - "The default external representation for a type tag. See - 13.3(75)." + "The default external representation for a type tag. See 13.3(75)." The default external representation for a type tag is the fully expanded name of the type in upper case letters. @@ -448,12 +557,10 @@ implementation, so no non-default bit ordering is supported. The default bit ordering corresponds to the natural endianness of the target architecture. * - "The contents of the visible part of package ``System`` - and its language-defined children. See 13.7(2)." + "The contents of the visible part of package ``System``. See 13.7(2)." -See the definition of these packages in files :file:`system.ads` and -:file:`s-stoele.ads`. Note that two declarations are added to package -System. +See the definition of package System in :file:`system.ads`. +Note that two declarations are added to package System. .. code-block:: ada @@ -461,14 +568,21 @@ System. Max_Interrupt_Priority : constant Positive := Interrupt_Priority'Last; * - "The contents of the visible part of package - ``System.Machine_Code``, and the meaning of - *code_statements*. See 13.8(7)." + "The range of Storage_Elements.Storage_Offset, the modulus of + Storage_Elements.Storage_Element, and the declaration of + Storage_Elements.Integer_Address. See 13.7.1(11)." + +See the definition of package System.Storage_Elements in :file:`s-stoele.ads`. + +* + "The contents of the visible part of package ``System.Machine_Code``, + and the meaning of *code_statements*. See 13.8(7)." See the definition and documentation in file :file:`s-maccod.ads`. * - "The effect of unchecked conversion. See 13.9(11)." + "The result of unchecked conversion for instances with scalar result + types whose result is not defined by the language. See 13.9(11)." Unchecked conversion between types of the same size results in an uninterpreted transmission of the bits from one type @@ -485,69 +599,43 @@ greater than the source alignment, then a copy of the result is made with appropriate alignment * - "The semantics of operations on invalid representations. - See 13.9.2(10-11)." - -For assignments and other operations where the use of invalid values cannot -result in erroneous behavior, the compiler ignores the possibility of invalid -values. An exception is raised at the point where an invalid value would -result in erroneous behavior. For example executing: + "The result of unchecked conversion for instances with nonscalar result + types whose result is not defined by the language. See 13.9(11)." -.. code-block:: ada - - procedure invalidvals is - X : Integer := -1; - Y : Natural range 1 .. 10; - for Y'Address use X'Address; - Z : Natural range 1 .. 10; - A : array (Natural range 1 .. 10) of Integer; - begin - Z := Y; -- no exception - A (Z) := 3; -- exception raised; - end; - -As indicated, an exception is raised on the array assignment, but not -on the simple assignment of the invalid negative value from Y to Z. +See preceding definition for the scalar result case. * - "The manner of choosing a storage pool for an access type - when ``Storage_Pool`` is not specified for the type. See 13.11(17)." + "Whether or not the implementation provides user-accessible + names for the standard pool type(s). See 13.11(17)." There are 3 different standard pools used by the compiler when ``Storage_Pool`` is not specified depending whether the type is local to a subprogram or defined at the library level and whether -``Storage_Size``is specified or not. See documentation in the runtime +``Storage_Size``is specified or not. See documentation in the runtime library units ``System.Pool_Global``, ``System.Pool_Size`` and ``System.Pool_Local`` in files :file:`s-poosiz.ads`, :file:`s-pooglo.ads` and :file:`s-pooloc.ads` for full details on the -default pools used. - -* - "Whether or not the implementation provides user-accessible - names for the standard pool type(s). See 13.11(17)." - -See documentation in the sources of the run time mentioned in the previous -paragraph. All these pools are accessible by means of `with`\ ing +default pools used. All these pools are accessible by means of `with`\ ing these units. * - "The meaning of ``Storage_Size``. See 13.11(18)." + "The meaning of ``Storage_Size`` when neither the Storage_Size nor the + Storage_Pool is specified for an access type. See 13.11(18)." ``Storage_Size`` is measured in storage units, and refers to the total space available for an access type collection, or to the primary stack space for a task. * - "Implementation-defined aspects of storage pools. See - 13.11(22)." + "The effect of specifying aspect Default_Storage_Pool on an instance + of a language-defined generic unit. See 13.11.3(5)." -See documentation in the sources of the run time mentioned in the -paragraph about standard storage pools above -for details on GNAT-defined aspects of storage pools. +Instances of language-defined generic units are treated the same as other +instances with respect to the Default_Storage_Pool aspect. * - "The set of restrictions allowed in a pragma - ``Restrictions``. See 13.12(7)." + "Implementation-defined restrictions allowed in a pragma + ``Restrictions``. See 13.12(8.7)." See :ref:`Standard_and_Implementation_Defined_Restrictions`. @@ -555,14 +643,19 @@ See :ref:`Standard_and_Implementation_Defined_Restrictions`. "The consequences of violating limitations on ``Restrictions`` pragmas. See 13.12(9)." -Restrictions that can be checked at compile time result in illegalities -if violated. Currently there are no other consequences of violating -restrictions. +Restrictions that can be checked at compile time are enforced at +compile time; violations are illegal. For other restrictions, any +violation during program execution results in erroneous execution. * - "The representation used by the ``Read`` and - ``Write`` attributes of elementary types in terms of stream - elements. See 13.13.2(9)." + "Implementation-defined usage profiles allowed in a pragma Profile. + See 13.12(15)." + +See :ref:`Implementation_Defined_Pragmas`. + +* + "The contents of the stream elements read and written by the Read and + Write attributes of elementary types. See 13.13.2(9)." The representation is the in-memory representation of the base type of the type, using the number of bits corresponding to the @@ -575,12 +668,29 @@ the type, using the number of bits corresponding to the See items describing the integer and floating-point types supported. * - "The string returned by ``Character_Set_Version``. - See A.3.5(3)." + "The values returned by Strings.Hash. See A.4.9(3)." + +This hash function has predictable collisions and is subject to +equivalent substring attacks. It is not suitable for construction of a +hash table keyed on possibly malicious user input. + +* + "The value returned by a call to a Text_Buffer Get procedure if any + character in the returned sequence is not defined in Character. + See A.4.12(34)." + +The contents of a buffer is represented internally as a UTF_8 string. +The value return by Text_Buffer.Get is the result of passing that +UTF_8 string to UTF_Encoding.Strings.Decode. + +* + "The value returned by a call to a Text_Buffer Wide_Get procedure if + any character in the returned sequence is not defined in Wide_Character. + See A.4.12(34)." -``Ada.Wide_Characters.Handling.Character_Set_Version`` returns -the string "Unicode 4.0", referring to version 4.0 of the -Unicode specification. +The contents of a buffer is represented internally as a UTF_8 string. +The value return by Text_Buffer.Wide_Get is the result of passing that +UTF_8 string to UTF_Encoding.Wide_Strings.Decode. * "The accuracy actually achieved by the elementary @@ -610,14 +720,6 @@ Maximum image width is 6864, see library file :file:`s-rannum.ads`. Maximum image width is 6864, see library file :file:`s-rannum.ads`. * - "The algorithms for random number generation. See - A.5.2(32)." - -The algorithm is the Mersenne Twister, as documented in the source file -:file:`s-rannum.adb`. This version of the algorithm has a period of -2**19937-1. - -* "The string representation of a random number generator's state. See A.5.2(38)." @@ -626,32 +728,16 @@ the fixed-width decimal representations of the 624 32-bit integers of the state vector. * - "The minimum time interval between calls to the - time-dependent Reset procedure that are guaranteed to initiate different - random number sequences. See A.5.2(45)." - -The minimum period between reset calls to guarantee distinct series of -random numbers is one microsecond. - -* "The values of the ``Model_Mantissa``, ``Model_Emin``, ``Model_Epsilon``, ``Model``, ``Safe_First``, and ``Safe_Last`` attributes, if the Numerics Annex is not supported. See A.5.3(72)." -Run the compiler with *-gnatS* to produce a listing of package -``Standard``, has the values of all numeric attributes. +Running the compiler with *-gnatS* to produce a listing of package +``Standard`` displays the values of these attributes. * - "Any implementation-defined characteristics of the - input-output packages. See A.7(14)." - -There are no special implementation defined characteristics for these -packages. - -* - "The value of ``Buffer_Size`` in ``Storage_IO``. See - A.9(10)." + "The value of ``Buffer_Size`` in ``Storage_IO``. See A.9(10)." All type representations are contiguous, and the ``Buffer_Size`` is the value of ``type'Size`` rounded up to the next storage unit @@ -662,17 +748,22 @@ boundary. standard error See A.10(5)." These files are mapped onto the files provided by the C streams -libraries. See source file :file:`i-cstrea.ads` for further details. +libraries. See source file :file:`i-cstrea.ads` for further details. * - "The accuracy of the value produced by ``Put``. See - A.10.9(36)." + "The accuracy of the value produced by ``Put``. See A.10.9(36)." If more digits are requested in the output than are represented by the precision of the value, zeroes are output in the corresponding least significant digit positions. * + "Current size for a stream file for which positioning is not supported. + See A.12.1(1.1)." + +Positioning is supported. + +* "The meaning of ``Argument_Count``, ``Argument``, and ``Command_Name``. See A.15(1)." @@ -680,80 +771,66 @@ These are mapped onto the ``argv`` and ``argc`` parameters of the main program in the natural manner. * - "The interpretation of the ``Form`` parameter in procedure - ``Create_Directory``. See A.16(56)." + "The interpretation of file names and directory names. See A.16(46)." -The ``Form`` parameter is not used. +These names are interpreted consistently with the underlying file system. * - "The interpretation of the ``Form`` parameter in procedure - ``Create_Path``. See A.16(60)." + "The maxium value for a file size in Directories. See A.16(87)." -The ``Form`` parameter is not used. +Directories.File_Size'Last is equal to Long_Long_Integer'Last . * - "The interpretation of the ``Form`` parameter in procedure - ``Copy_File``. See A.16(68)." + "The result for Directories.Size for a directory or special file. + See A.16(93)." -The ``Form`` parameter is case-insensitive. -Two fields are recognized in the ``Form`` parameter:: +Name_Error is raised. - *preserve=<value>* - *mode=<value>* +* + "The result for Directories.Modification_Time for a directory or special file. + See A.16(93)." -<value> starts immediately after the character '=' and ends with the -character immediately preceding the next comma (',') or with the last -character of the parameter. +Name_Error is raised. -The only possible values for preserve= are: +* + "The interpretation of a nonnull search pattern in Directories. + See A.16(104)." -================== =================================================================== -Value Meaning -================== =================================================================== -*no_attributes* Do not try to preserve any file attributes. This is the - default if no preserve= is found in Form. -*all_attributes* Try to preserve all file attributes (timestamps, access rights). -*timestamps* Preserve the timestamp of the copied file, but not the other - file attributes. -================== =================================================================== +When the ``Pattern`` parameter is not the null string, it is interpreted +according to the syntax of regular expressions as defined in the +``GNAT.Regexp`` package. -The only possible values for mode= are: +See :ref:`GNAT.Regexp_(g-regexp.ads)`. -============== =============================================================================== -Value Meaning -============== =============================================================================== -*copy* Only do the copy if the destination file does not already exist. - If it already exists, Copy_File fails. -*overwrite* Copy the file in all cases. Overwrite an already existing destination file. -*append* Append the original file to the destination file. If the destination file - does not exist, the destination file is a copy of the source file. - When mode=append, the field preserve=, if it exists, is not taken into account. -============== =============================================================================== +* + "The results of a Directories search if the contents of the directory are + altered while a search is in progress. See A.16(110)." -If the Form parameter includes one or both of the fields and the value or -values are incorrect, Copy_file fails with Use_Error. +The effect of a call to Get_Next_Entry is determined by the current +state of the directory. -Examples of correct Forms:: +* + "The definition and meaning of an environment variable. See A.17(1)." - Form => "preserve=no_attributes,mode=overwrite" (the default) - Form => "mode=append" - Form => "mode=copy, preserve=all_attributes" +This definition is determined by the underlying operating system. -Examples of incorrect Forms:: +* + "The circumstances where an environment variable cannot be defined. + See A.17(16)." - Form => "preserve=junk" - Form => "mode=internal, preserve=timestamps" + There are no such implementation-defined circumstances. * - "The interpretation of the ``Pattern`` parameter, when not the null string, - in the ``Start_Search`` and ``Search`` procedures. - See A.16(104) and A.16(112)." + "Environment names for which Set has the effect of Clear. See A.17(17)." -When the ``Pattern`` parameter is not the null string, it is interpreted -according to the syntax of regular expressions as defined in the -``GNAT.Regexp`` package. +There are no such names. -See :ref:`GNAT.Regexp_(g-regexp.ads)`. +* + "The value of Containers.Hash_Type'Modulus. The value of + Containers.Count_Type'Last. See A.18.1(7)." + +Containers.Hash_Type'Modulus is 2**32. +Containers.Count_Type'Last is 2**31 - 1. * "Implementation-defined convention names. See B.1(11)." @@ -806,9 +883,8 @@ Convention Name Interpretation Link names are the actual names used by the linker. * - "The manner of choosing link names when neither the link - name nor the address of an imported or exported entity is specified. See - B.1(36)." + "The manner of choosing link names when neither the link name nor the + address of an imported or exported entity is specified. See B.1(36)." The default linker name is that which would be assigned by the relevant external language, interpreting the Ada name as being in all lower case @@ -845,6 +921,12 @@ See files with prefix :file:`i-` in the distributed library. See files with prefix :file:`i-` in the distributed library. * + "The definitions of certain types and constants in Interfaces.C. + See B.3(41)." + +See source file :file:`i-c.ads`. + +* "The types ``Floating``, ``Long_Floating``, ``Binary``, ``Long_Binary``, ``Decimal_ Element``, and ``COBOL_Character``; and the initialization of the variables @@ -865,45 +947,54 @@ COBOL Ada For initialization, see the file :file:`i-cobol.ads` in the distributed library. * - "Support for access to machine instructions. See C.1(1)." + "The types Fortran_Integer, Real, Double_Precision, and Character_Set + in Interfaces.Fortran. See B.5(17)." -See documentation in file :file:`s-maccod.ads` in the distributed library. +See source file :file:`i-fortra.ads`. These types are derived, respectively, +from Integer, Float, Long_Float, and Character. * - "Implementation-defined aspects of access to machine - operations. See C.1(9)." + "Implementation-defined intrinsic subprograms. See C.1(1)." -See documentation in file :file:`s-maccod.ads` in the distributed library. +See separate section on Intrinsic Subprograms. * - "Implementation-defined aspects of interrupts. See C.3(2)." + "Any restrictions on a protected procedure or its containing type when an + aspect Attach_handler or Interrupt_Handler is specified. See C.3.1(17)." -Interrupts are mapped to signals or conditions as appropriate. See -definition of unit -``Ada.Interrupt_Names`` in source file :file:`a-intnam.ads` for details -on the interrupts supported on a particular target. +There are no such restrictions. * - "Implementation-defined aspects of pre-elaboration. See - C.4(13)." + "Any other forms of interrupt handler supported by the Attach_Handler and + Interrupt_Handler aspects. See C.3.1(19)." -GNAT does not permit a partition to be restarted without reloading, -except under control of the debugger. +There are no such forms. * - "The semantics of pragma ``Discard_Names``. See C.5(7)." + "The semantics of some attributes and functions of an entity for which + aspect Discard_Names is True. See C.5(7)." -Pragma ``Discard_Names`` causes names of enumeration literals to -be suppressed. In the presence of this pragma, the Image attribute +If Discard_Names is True for an enumeration type, the Image attribute provides the image of the Pos of the literal, and Value accepts Pos values. -For tagged types, when pragmas ``Discard_Names`` and ``No_Tagged_Streams`` -simultaneously apply, their Expanded_Name and External_Tag are initialized -with empty strings. This is useful to avoid exposing entity names at binary +If both of the aspects``Discard_Names`` and ``No_Tagged_Streams`` are true +for a tagged type, its Expanded_Name and External_Tag values are +empty strings. This is useful to avoid exposing entity names at binary level. * + "The modulus and size of Test_and_Set_Flag. See C.6.3(8)." + +The modulus is 2**8. The size is 8. + +* + "The value used to represent the set value for Atomic_Test_and_Set. + See C.6.3(10)." + +The value is 1. + +* "The result of the ``Task_Identification.Image`` attribute. See C.7.1(7)." @@ -939,32 +1030,11 @@ Protected entries or interrupt handlers can be executed by any convenient thread, so the value of ``Current_Task`` is undefined. * - "The effect of calling ``Current_Task`` from an entry - body or interrupt handler. See C.7.1(19)." + "Granularity of locking for Task_Attributes. See C.7.2(16)." -When GNAT can determine statically that ``Current_Task`` is called directly in -the body of an entry (or barrier) then a warning is emitted and ``Program_Error`` -is raised at run time. Otherwise, the effect of calling ``Current_Task`` from an -entry body or interrupt handler is to return the identification of the task -currently executing the code. - -* - "Implementation-defined aspects of - ``Task_Attributes``. See C.7.2(19)." - -There are no implementation-defined aspects of ``Task_Attributes``. - -* - "Values of all ``Metrics``. See D(2)." - -The metrics information for GNAT depends on the performance of the -underlying operating system. The sources of the run-time for tasking -implementation, together with the output from *-gnatG* can be -used to determine the exact sequence of operating systems calls made -to implement various tasking constructs. Together with appropriate -information on the performance of the underlying operating system, -on the exact target in use, this information can be used to determine -the required metrics. +No locking is needed if the formal type Attribute has the size and +alignment of either Integer or System.Address and the bit representation +of Initial_Value is all zeroes. Otherwise, locking is performed. * "The declarations of ``Any_Priority`` and @@ -993,23 +1063,14 @@ and appropriate, these threads correspond to native threads of the underlying operating system. * - "Implementation-defined *policy_identifiers* allowed - in a pragma ``Task_Dispatching_Policy``. See D.2.2(3)." - -There are no implementation-defined policy-identifiers allowed in this -pragma. - -* - "Implementation-defined aspects of priority inversion. See - D.2.2(16)." + "Implementation-defined task dispatching policies. See D.2.2(3)." -Execution of a task cannot be preempted by the implementation processing -of delay expirations for lower priority tasks. +There are no implementation-defined task dispatching policies. * - "Implementation-defined task dispatching. See D.2.2(18)." + "The value of Default_Quantum in Dispatching.Round_Robin. See D.2.5(4)." -The policy is the same as that of the underlying threads implementation. +The value is 10 milliseconds. * "Implementation-defined *policy_identifiers* allowed @@ -1045,12 +1106,9 @@ The ceiling priority of internal protected objects is There are no implementation-defined queuing policies. * - "On a multiprocessor, any conditions that cause the - completion of an aborted construct to be delayed later than what is - specified for a single processor. See D.6(3)." + "Implementation-defined admission policies. See D.4.1(1)." -The semantics for abort on a multi-processor is the same as on a single -processor, there are no further delays. +There are no implementation-defined admission policies. * "Any operations that implicitly require heap storage @@ -1060,43 +1118,75 @@ The only operation that implicitly requires heap storage allocation is task creation. * - "What happens when a task terminates in the presence of - pragma ``No_Task_Termination``. See D.7(15)." + "When restriction No_Dynamic_CPU_Assignment applies to a partition, the + processor on which a task with a CPU value of a Not_A_Specific_CPU will + execute. See D.7(10)." + +Unknown. + +* + "When restriction No_Task_Termination applies to a partition, what happens + when a task terminates. See D.7(15.1)." + +Execution is erroneous in that case. + +* + "The behavior when restriction Max_Storage_At_Blocking is violated. + See D.7(17)." + +Execution is erroneous in that case. + +* + "The behavior when restriction Max_Asynchronous_Select_Nesting is violated. + See D.7(18)." + +Execution is erroneous in that case. + +* + "The behavior when restriction Max_Tasks is violated. See D.7(19)." Execution is erroneous in that case. +* "Whether the use of pragma Restrictions results in a reduction in program + code or data size or execution time. See D.7(20)." + + Yes it can, but the precise circumstances and properties of such reductions + are difficult to characterize. + +* + "The value of Barrier_Limit'Last in Synchronous_Barriers. See D.10.1(4)." + +Synchronous_Barriers.Barrier_Limit'Last is Integer'Last . + * - "Implementation-defined aspects of pragma - ``Restrictions``. See D.7(20)." + "When an aborted task that is waiting on a Synchronous_Barrier is aborted. + See D.10.1(13)." -There are no such implementation-defined aspects. +Difficult to characterize. * - "Implementation-defined aspects of package - ``Real_Time``. See D.8(17)." + "The value of Min_Handler_Ceiling in Execution_Time.Group_Budgets. + See D.14.2(7)." -There are no implementation defined aspects of package ``Real_Time``. +See source file :file:`a-etgrbu.ads`. * - "Implementation-defined aspects of - *delay_statements*. See D.9(8)." + "The value of CPU_Range'Last in System.Multiprocessors. See D.16(4)." -Any difference greater than one microsecond will cause the task to be -delayed (see D.9(7)). +See source file :file:`s-multip.ads`. * - "The upper bound on the duration of interrupt blocking - caused by the implementation. See D.12(5)." + "The processor on which the environment task executes in the absence + of a value for the aspect CPU. See D.16(13)." -The upper bound is determined by the underlying operating system. In -no cases is it more than 10 milliseconds. +Unknown. * "The means for creating and executing distributed programs. See E(5)." The GLADE package provides a utility GNATDIST for creating and executing -distributed programs. See the GLADE reference manual for further details. +distributed programs. See the GLADE reference manual for further details. * "Any events that can result in a partition becoming @@ -1105,24 +1195,13 @@ distributed programs. See the GLADE reference manual for further details. See the GLADE reference manual for full details on such events. * - "The scheduling policies, treatment of priorities, and - management of shared resources between partitions in certain cases. See - E.1(11)." + "The scheduling policies, treatment of priorities, and management of + shared resources between partitions in certain cases. See E.1(11)." See the GLADE reference manual for full details on these aspects of multi-partition execution. * - "Events that cause the version of a compilation unit to - change. See E.3(5)." - -Editing the source file of a compilation unit, or the source files of -any units on which it is dependent in a significant way cause the version -to change. No other actions cause the version number to change. All changes -are significant except those which affect only layout, capitalization or -comments. - -* "Whether the execution of the remote subprogram is immediately aborted as a result of cancellation. See E.4(13)." @@ -1130,14 +1209,12 @@ See the GLADE reference manual for details on the effect of abort in a distributed application. * - "Implementation-defined aspects of the PCS. See E.5(25)." + "The range of type System.RPC.Partition_Id. See E.5(14)." -See the GLADE reference manual for a full description of all implementation -defined aspects of the PCS. +System.RPC.Partion_ID'Last is Integer'Last. See source file :file:`s-rpc.ads`. * - "Implementation-defined interfaces in the PCS. See - E.5(26)." + "Implementation-defined interfaces in the PCS. See E.5(26)." See the GLADE reference manual for a full description of all implementation defined interfaces. @@ -1228,9 +1305,8 @@ properly generated. Not relevant, division is IEEE exact. * - "The definition of close result set, which determines the - accuracy of certain fixed point multiplications and divisions. See - G.2.3(5)." + "The definition of close result set, which determines the accuracy of + certain fixed point multiplications and divisions. See G.2.3(5)." Operations in the close result set are performed using IEEE long format floating-point arithmetic. The input operands are converted to @@ -1291,28 +1367,20 @@ IEEE infinite and Nan values are produced as appropriate. Information on those subjects is not yet available. * - "Information regarding bounded errors and erroneous - execution. See H.2(1)." - -Information on this subject is not yet available. - -* - "Implementation-defined aspects of pragma - ``Inspection_Point``. See H.3.2(8)." + "The accuracy requirements for the subprograms Solve, Inverse, + Determinant, Eigenvalues and Eigensystem for type Real_Matrix. + See G.3.1(81)." -Pragma ``Inspection_Point`` ensures that the variable is live and can -be examined by the debugger at the inspection point. +Information on those subjects is not yet available. * - "Implementation-defined aspects of pragma - ``Restrictions``. See H.4(25)." + "The accuracy requirements for the subprograms Solve, Inverse, + Determinant, Eigenvalues and Eigensystem for type Complex_Matrix. + See G.3.2(149)." -There are no implementation-defined aspects of pragma ``Restrictions``. The -use of pragma ``Restrictions [No_Exceptions]`` has no effect on the -generated code. Checks must suppressed by use of pragma ``Suppress``. +Information on those subjects is not yet available. * - "Any restrictions on pragma ``Restrictions``. See - H.4(27)." + "The consequences of violating No_Hidden_Indirect_Globals. See H.4(23.9)." -There are no restrictions on pragma ``Restrictions``. +Execution is erroneous in that case. diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 6c81ca7..0375982 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2270,8 +2270,15 @@ of GNAT specific extensions are recognized as follows: values of the composite type shall be covered. The composite type of the selector shall be a nonlimited untagged (but possibly discriminated) record type, all of whose subcomponent subtypes are either static discrete - subtypes or record types that meet the same restrictions. Support for arrays - is planned, but not yet implemented. + subtypes or record types that meet the same restrictions. + + Support for casing on arrays (and on records that contain arrays) is + currently subject to some restrictions. Non-positional + array aggregates are not supported as (or within) case choices. Likewise + for array type and subtype names. The current implementation exceeds + compile-time capacity limits in some annoyingly common scenarios; the + message generated in such cases is usually "Capacity exceeded in compiling + case statement with composite selector type". In addition, pattern bindings are supported. This is a mechanism for binding a name to a component of a matching value for use within @@ -2280,7 +2287,8 @@ of GNAT specific extensions are recognized as follows: "is <identifier>". In the special case of a "box" component association, the identifier may instead be provided within the box. Either of these indicates that the given identifer denotes (a constant view of) the matching - subcomponent of the case selector. + subcomponent of the case selector. Binding is not yet supported for arrays + or subcomponents thereof. Consider this example (which uses type Rec from the previous example): @@ -4908,43 +4916,6 @@ aspects, but is prepared to ignore the pragmas. The assertion policy that controls this pragma is ``Post'Class``, not ``Post_Class``. -Pragma Rename_Pragma -============================ -.. index:: Pragmas, synonyms - -Syntax: - - -:: - - pragma Rename_Pragma ( - [New_Name =>] IDENTIFIER, - [Renamed =>] pragma_IDENTIFIER); - -This pragma provides a mechanism for supplying new names for existing -pragmas. The ``New_Name`` identifier can subsequently be used as a synonym for -the Renamed pragma. For example, suppose you have code that was originally -developed on a compiler that supports Inline_Only as an implementation defined -pragma. And suppose the semantics of pragma Inline_Only are identical to (or at -least very similar to) the GNAT implementation defined pragma -Inline_Always. You could globally replace Inline_Only with Inline_Always. - -However, to avoid that source modification, you could instead add a -configuration pragma: - -.. code-block:: ada - - pragma Rename_Pragma ( - New_Name => Inline_Only, - Renamed => Inline_Always); - - -Then GNAT will treat "pragma Inline_Only ..." as if you had written -"pragma Inline_Always ...". - -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. - Pragma Pre ========== .. index:: Pre @@ -5729,6 +5700,43 @@ In the generic unit, the formal type is subject to all restrictions pertaining to remote access to class-wide types. At instantiation, the actual type must be a remote access to class-wide type. +Pragma Rename_Pragma +============================ +.. index:: Pragmas, synonyms + +Syntax: + + +:: + + pragma Rename_Pragma ( + [New_Name =>] IDENTIFIER, + [Renamed =>] pragma_IDENTIFIER); + +This pragma provides a mechanism for supplying new names for existing +pragmas. The ``New_Name`` identifier can subsequently be used as a synonym for +the Renamed pragma. For example, suppose you have code that was originally +developed on a compiler that supports Inline_Only as an implementation defined +pragma. And suppose the semantics of pragma Inline_Only are identical to (or at +least very similar to) the GNAT implementation defined pragma +Inline_Always. You could globally replace Inline_Only with Inline_Always. + +However, to avoid that source modification, you could instead add a +configuration pragma: + +.. code-block:: ada + + pragma Rename_Pragma ( + New_Name => Inline_Only, + Renamed => Inline_Always); + + +Then GNAT will treat "pragma Inline_Only ..." as if you had written +"pragma Inline_Always ...". + +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. + Pragma Restricted_Run_Time ========================== diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst new file mode 100644 index 0000000..1c46e3a4 --- /dev/null +++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst @@ -0,0 +1,89 @@ +.. _Security_Hardening_Features: + +*************************** +Security Hardening Features +*************************** + +This chapter describes Ada extensions aimed at security hardening that +are provided by GNAT. + +.. Register Scrubbing: + +Register Scrubbing +================== + +GNAT can generate code to zero-out hardware registers before returning +from a subprogram. + +It can be enabled with the *-fzero-call-used-regs* command line +option, to affect all subprograms in a compilation, and with a +:samp:`Machine_Attribute` pragma, to affect only specific subprograms. + +.. code-block:: ada + + procedure Foo; + pragma Machine_Attribute (Foo, "zero_call_used_regs", "used"); + -- Before returning, Foo scrubs only call-clobbered registers + -- that it uses itself. + + function Bar return Integer; + pragma Machine_Attribute (Bar, "zero_call_used_regs", "all"); + -- Before returning, Bar scrubs all call-clobbered registers. + + +For usage and more details on the command line option, and on the +``zero_call_used_regs`` attribute, see :title:`Using the GNU Compiler +Collection (GCC)`. + + +.. Stack Scrubbing: + +Stack Scrubbing +=============== + +GNAT can generate code to zero-out stack frames used by subprograms. + +It can be activated with the :samp:`Machine_Attribute` pragma, on +specific subprograms and variables. + +.. code-block:: ada + + function Foo returns Integer; + pragma Machine_Attribute (Foo, "strub"); + -- Foo and its callers are modified so as to scrub the stack + -- space used by Foo after it returns. + + procedure Bar; + pragma Machine_Attribute (Bar, "strub", "internal"); + -- Bar is turned into a wrapper for its original body, + -- and they scrub the stack used by the original body. + + Var : Integer; + pragma Machine_Attribute (Var, "strub"); + -- Reading from Var in a subprogram enables stack scrubbing + -- of the stack space used by the subprogram. + + +There are also *-fstrub* command line options to control default +settings. For usage and more details on the command line option, and +on the ``strub`` attribute, see :title:`Using the GNU Compiler +Collection (GCC)`. + +Note that Ada secondary stacks are not scrubbed. The restriction +``No_Secondary_Stack`` avoids their use, and thus their accidental +preservation of data that should be scrubbed. + +Also note that the machine attribute is not integrated in the Ada type +system. Though it may modify subprogram and variable interfaces, it +is not fully reflected in Ada types, ``Access`` attributes, renaming +and overriding. Every access type, renaming, and overriding and +overridden dispatching operations that may refer to an entity with an +attribute-modified interface must be annotated with the same +interface-modifying attribute, or with an interface-compatible one. + +Even then, the pragma is currently only functional when applied to +subprograms and scalar variables; other uses, such as directly on +types and subtypes, may be silently ignored. Specifically, it is not +currently recommended to rely on any effects this pragma might be +expected to have when calling subprograms through access-to-subprogram +variables. 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 3e7dc051..cbd780b 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 @@ -870,6 +870,44 @@ used, the compiler is allowed to suppress the elaboration counter normally associated with the unit. This counter is typically used to check for access before elaboration and to control multiple elaboration attempts. +No_Dynamic_Accessibility_Checks +------------------------------- +.. index:: No_Dynamic_Accessibility_Checks + +[GNAT] No dynamic accessibility checks are generated when this restriction is +in effect. Instead, dangling references are prevented via more conservative +compile-time checking. More specifically, existing compile-time checks are +enforced but with more conservative assumptions about the accessibility levels +of the relevant entities. These conservative assumptions eliminate the need for +dynamic accessibility checks. + +These new rules for computing (at compile-time) the accessibility level of an +anonymous access type T are as follows: + +* + If T is a function result type then, from the caller's perspective, its level + is that of the innermost master enclosing the function call. From the callee's + perspective, the level of parameters and local variables of the callee is + statically deeper than the level of T. + + For any other accessibility level L such that the level of parameters and local + variables of the callee is statically deeper than L, the level of T (from the + callee's perspective) is also statically deeper than L. +* + If T is the type of a formal parameter then, from the caller's perspective, + its level is at least as deep as that of the type of the corresponding actual + parameter (whatever that actual parameter might be). From the callee's + perspective, the level of parameters and local variables of the callee is + statically deeper than the level of T. +* + If T is the type of a discriminant then its level is that of the discriminated + type. +* + If T is the type of a stand-alone object then its level is the level of the + object. +* + In all other cases, the level of T is as defined by the existing rules of Ada. + No_Dynamic_Sized_Objects ------------------------ .. index:: No_Dynamic_Sized_Objects 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 5a69967..67fd130 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 @@ -1497,9 +1497,10 @@ Alphabetical List of All Switches :switch:`-gnateA` Check that the actual parameters of a subprogram call are not aliases of one - another. To qualify as aliasing, the actuals must denote objects of a composite - type, their memory locations must be identical or overlapping, and at least one - of the corresponding formal parameters must be of mode OUT or IN OUT. + another. To qualify as aliasing, their memory locations must be identical or + overlapping, at least one of the corresponding formal parameters must be of + mode OUT or IN OUT, and at least one of the corresponding formal parameters + must have its parameter passing mechanism not specified. .. code-block:: ada diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index c4f186e..24ef9d6 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -3680,8 +3680,9 @@ execution of this erroneous program: The ``gnatmem`` utility monitors dynamic allocation and deallocation activity in a program, and displays information about incorrect deallocations and possible sources of memory leaks. - It is designed to work in association with a static runtime library - only and in this context provides three types of information: + It is designed to work for fixed-position executables in association + with a static runtime library only and in this context provides three + types of information: * General information concerning memory management, such as the total number of allocations and deallocations, the amount of allocated @@ -3711,15 +3712,16 @@ execution of this erroneous program: $ gnatmem [ switches ] [ DEPTH ] user_program - The program must have been linked with the instrumented version of the + The user program must be linked with the instrumented version of the allocation and deallocation routines. This is done by linking with the :file:`libgmem.a` library. For correct symbolic backtrace information, - the user program should be compiled with debugging options - (see :ref:`Switches_for_gcc`). For example to build :file:`my_program`: + the user program should also both be compiled with debugging options + (see :ref:`Switches_for_gcc`) and be linked at a fixed position. For + example to build :file:`my_program` with ``gnatmake``: :: - $ gnatmake -g my_program -largs -lgmem + $ gnatmake -g my_program -largs -lgmem -no-pie As library :file:`libgmem.a` contains an alternate body for package ``System.Memory``, :file:`s-memory.adb` should not be compiled and linked diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index f152ce3..d030cd4 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -4294,10 +4294,13 @@ building specialized scripts. Standard Output. Has no effect otherwise. :switch:`--count={N}` - If specified, compute the symbolic traceback ``N`` times in a row. - This option is mostly useful for measuring the performance of - ``gnatsymbolize``, particularly in the case where the cache is - being used. + Compute the symbolic traceback ``N`` times in a row. This option + is mostly useful for measuring the performance of ``gnatsymbolize``, + particularly in the case where the cache is being used. + + :switch:`--load` + Interpret the first address as the load address of the executable. + This is needed for position-independent executables on Windows. Requirements for Correct Operation ---------------------------------- @@ -4311,12 +4314,7 @@ building specialized scripts. This program provides a functionality similar to ``addr2line``. It has fewer options to tailor its output, but has been designed to require fewer of the DWARF sections to be present in the - executable. In particular, the following sections can be - stripped from the executable without impact to ``gnatsymbolize``'s - functionality: - - * ``.debug_str`` - * ``.debug_ranges`` + executable. In particular, it works for code compiled with ``-g1``. .. only:: PRO or GPL diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst index 13993b8..4f68d25 100644 --- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst +++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst @@ -217,7 +217,10 @@ this in a library package body in your application: (if geteuid = 0 then True else raise Program_Error with "must be root"); It gets the effective user id, and if it's not 0 (i.e. root), it raises -Program_Error. +Program_Error. Note that if you re running the code in a container, this may +not be sufficient, as you may have sufficient priviledge on the container, +but not on the host machine running the container, so check that you also +have sufficient priviledge for running the container image. .. index:: Linux .. index:: GNU/Linux 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 39b9ca1..4a3b84d 100644 --- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst +++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst @@ -1409,16 +1409,12 @@ recognized by GNAT:: Check_Float_Overflow Check_Name Check_Policy - Compile_Time_Error - Compile_Time_Warning - Compiler_Unit - Compiler_Unit_Warning Component_Alignment Convention_Identifier Debug_Policy - Detect_Blocking Default_Scalar_Storage_Order Default_Storage_Pool + Detect_Blocking Disable_Atomic_Synchronization Discard_Names Elaboration_Checks @@ -1437,7 +1433,6 @@ recognized by GNAT:: Locking_Policy No_Component_Reordering No_Heap_Finalization - No_Run_Time No_Strict_Aliasing Normalize_Scalars Optimize_Alignment @@ -1449,17 +1444,12 @@ recognized by GNAT:: Priority_Specific_Dispatching Profile Profile_Warnings - Propagate_Exceptions Queuing_Policy - Rational - Ravenscar Rename_Pragma - Restricted_Run_Time Restrictions - Restrictions_Warnings + Restriction_Warnings Reviewable Short_Circuit_And_Or - Short_Descriptors Source_File_Name Source_File_Name_Project SPARK_Mode @@ -1468,7 +1458,6 @@ recognized by GNAT:: Suppress_Exception_Locations Task_Dispatching_Policy Unevaluated_Use_Of_Old - Universal_Data Unsuppress Use_VADS_Size Validity_Checks @@ -1514,7 +1503,7 @@ only to the unit in which the pragma appears, and not to any other units. The exception is No_Elaboration_Code which always applies to the entire object file from a compilation, i.e. to the body, spec, and all subunits. This restriction can be specified in a configuration pragma file, or it -can be on the body and/or the spec (in eithe case it applies to all the +can be on the body and/or the spec (in either case it applies to all the relevant units). It can appear on a subunit only if it has previously appeared in the body of spec. @@ -4526,8 +4515,8 @@ Some of the known limitations include: constants. Function macros (macros with arguments) are partially translated as comments, to be completed manually if needed. * some extensions (e.g. vector types) are not supported -* pointers to pointers or complex structures are mapped to System.Address -* identifiers with identical name (except casing) will generate compilation +* pointers to pointers are mapped to System.Address +* identifiers with identical name (except casing) may generate compilation errors (e.g. ``shm_get`` vs ``SHM_GET``). The code is generated using Ada 2012 syntax, which makes it easier to interface @@ -4546,14 +4535,17 @@ header files needed by these files transitively. For example: .. code-block:: sh - $ g++ -c -fdump-ada-spec -C /usr/include/time.h + $ gcc -c -fdump-ada-spec -C /usr/include/time.h $ gcc -c *.ads will generate, under GNU/Linux, the following files: :file:`time_h.ads`, :file:`bits_time_h.ads`, :file:`stddef_h.ads`, :file:`bits_types_h.ads` which correspond to the files :file:`/usr/include/time.h`, -:file:`/usr/include/bits/time.h`, etc..., and will then compile these Ada specs -in Ada 2005 mode. +:file:`/usr/include/bits/time.h`, etc..., and then compile these Ada specs. +That is to say, the name of the Ada specs is in keeping with the relative path +under :file:`/usr/include/` of the header files. This behavior is specific to +paths ending with :file:`/include/`; in all the other cases, the name of the +Ada specs is derived from the simple name of the header files instead. The :switch:`-C` switch tells ``gcc`` to extract comments from headers, and will attempt to generate corresponding Ada comments. @@ -4564,39 +4556,8 @@ can use instead the :switch:`-fdump-ada-spec-slim` switch. You can optionally specify a parent unit, of which all generated units will be children, using :switch:`-fada-spec-parent={unit}`. -Note that we recommend when possible to use the *g++* driver to -generate bindings, even for most C headers, since this will in general -generate better Ada specs. For generating bindings for C++ headers, it is -mandatory to use the *g++* command, or *gcc -x c++* which -is equivalent in this case. If *g++* cannot work on your C headers -because of incompatibilities between C and C++, then you can fallback to -``gcc`` instead. - -For an example of better bindings generated from the C++ front-end, -the name of the parameters (when available) are actually ignored by the C -front-end. Consider the following C header: - -.. code-block:: c - - extern void foo (int variable); - -with the C front-end, ``variable`` is ignored, and the above is handled as: - -.. code-block:: c - - extern void foo (int); - -generating a generic: - -.. code-block:: ada - - procedure foo (param1 : int); - -with the C++ front-end, the name is available, and we generate: - -.. code-block:: ada - - procedure foo (variable : int); +The simple ``gcc```-based command works only for C headers. For C++ headers +you need to use either the ``g++`` command or the combination ``gcc -x c++```. In some cases, the generated bindings will be more complete or more meaningful when defining some macros, which you can do via the :switch:`-D` switch. This @@ -4604,7 +4565,7 @@ is for example the case with :file:`Xlib.h` under GNU/Linux: .. code-block:: sh - $ g++ -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h + $ gcc -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h The above will generate more complete bindings than a straight call without the :switch:`-DXLIB_ILLEGAL_ACCESS` switch. @@ -4626,7 +4587,7 @@ and then generate Ada bindings from this file: .. code-block:: sh - $ g++ -c -fdump-ada-spec readline1.h + $ gcc -c -fdump-ada-spec readline1.h .. _Generating_bindings_for_C++_headers: @@ -4851,7 +4812,7 @@ GNAT and Other Compilation Models ================================= This section compares the GNAT model with the approaches taken in -other environents, first the C/C++ model and then the mechanism that +other environments, first the C/C++ model and then the mechanism that has been used in other Ada systems, in particular those traditionally used for Ada 83. diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb index 15bd9e8..0274e6b 100644 --- a/gcc/ada/einfo-utils.adb +++ b/gcc/ada/einfo-utils.adb @@ -364,7 +364,9 @@ package body Einfo.Utils is function Known_Alignment (E : Entity_Id) return B is begin - return not Field_Is_Initial_Zero (E, F_Alignment); + -- For some reason, Empty is passed to this sometimes + + return No (E) or else not Field_Is_Initial_Zero (E, F_Alignment); end Known_Alignment; procedure Reinit_Alignment (Id : E) is @@ -414,8 +416,7 @@ package body Einfo.Utils is if Use_New_Unknown_Rep then return not Field_Is_Initial_Zero (E, F_Esize); else - return Esize (E) /= Uint_0 - and then Present (Esize (E)); + return Present (Esize (E)) and then Esize (E) /= Uint_0; end if; end Known_Esize; @@ -654,16 +655,21 @@ package body Einfo.Utils is P := Parent (Id); end if; + while Nkind (P) in N_Selected_Component | N_Expanded_Name + or else (Nkind (P) = N_Defining_Program_Unit_Name + and then Is_Child_Unit (Id)) loop - if Nkind (P) in N_Selected_Component | N_Expanded_Name - or else (Nkind (P) = N_Defining_Program_Unit_Name - and then Is_Child_Unit (Id)) - then - P := Parent (P); - else - return P; - end if; + P := Parent (P); end loop; + + if Is_Itype (Id) + and then Nkind (P) not in + N_Full_Type_Declaration | N_Subtype_Declaration + then + P := Empty; + end if; + + return P; end Declaration_Node; --------------------- @@ -702,7 +708,7 @@ package body Einfo.Utils is -- Entry_Index_Type -- ---------------------- - function Entry_Index_Type (Id : E) return N is + function Entry_Index_Type (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Entry_Family); return Etype (Discrete_Subtype_Definition (Parent (Id))); @@ -1424,26 +1430,19 @@ package body Einfo.Utils is function Is_Dynamic_Scope (Id : E) return B is begin - return - Ekind (Id) = E_Block - or else - Ekind (Id) = E_Function - or else - Ekind (Id) = E_Procedure - or else - Ekind (Id) = E_Subprogram_Body - or else - Ekind (Id) = E_Task_Type - or else - (Ekind (Id) = E_Limited_Private_Type - and then Present (Full_View (Id)) - and then Ekind (Full_View (Id)) = E_Task_Type) - or else - Ekind (Id) = E_Entry - or else - Ekind (Id) = E_Entry_Family + return Ekind (Id) in E_Block + -- Including an E_Block that came from an N_Expression_With_Actions + | E_Entry + | E_Entry_Family + | E_Function + | E_Procedure + | E_Return_Statement + | E_Subprogram_Body + | E_Task_Type or else - Ekind (Id) = E_Return_Statement; + (Ekind (Id) = E_Limited_Private_Type + and then Present (Full_View (Id)) + and then Ekind (Full_View (Id)) = E_Task_Type); end Is_Dynamic_Scope; -------------------- @@ -1746,7 +1745,7 @@ package body Einfo.Utils is -- Link_Entities -- ------------------- - procedure Link_Entities (First : Entity_Id; Second : Node_Id) is + procedure Link_Entities (First, Second : Entity_Id) is begin if Present (Second) then Set_Prev_Entity (Second, First); -- First <-- Second @@ -1975,6 +1974,8 @@ package body Einfo.Utils is function Next_Index (Id : Node_Id) return Node_Id is begin + pragma Assert (Nkind (Id) in N_Is_Index); + pragma Assert (No (Next (Id)) or else Nkind (Next (Id)) in N_Is_Index); return Next (Id); end Next_Index; diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads index 4eca35e..8046722 100644 --- a/gcc/ada/einfo-utils.ads +++ b/gcc/ada/einfo-utils.ads @@ -625,7 +625,7 @@ package Einfo.Utils is -- WARNING: There is a matching C declaration of this subprogram in fe.h - procedure Link_Entities (First : Entity_Id; Second : Entity_Id); + procedure Link_Entities (First, Second : Entity_Id); -- Link entities First and Second in one entity chain. -- -- NOTE: No updates are done to the First_Entity and Last_Entity fields diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 39ddd66..0239a70 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -610,12 +610,23 @@ package Einfo is -- tables must be consulted to determine if there actually is an active -- Suppress or Unsuppress pragma that applies to the entity. --- Class_Wide_Clone --- Defined on subprogram entities. Set if the subprogram has a class-wide --- pre- or postcondition, and the expression contains calls to other --- primitive funtions of the type. Used to implement properly the --- semantics of inherited operations whose class-wide condition may --- be different from that of the ancestor (See AI012-0195). +-- Class_Postconditions +-- Defined on subprogram entities. Set if the subprogram has class-wide +-- postconditions. Denotes the (and-then) expression built by merging +-- inherited class-wide postconditions with its own class-wide +-- postconditions. + +-- Class_Preconditions +-- Defined on subprogram entities. Set if the subprogram has class-wide +-- preconditions. Denotes the (or-else) expression built by merging +-- inherited class-wide preconditions with its own class-wide +-- preconditions. + +-- Class_Preconditions_Subprogram +-- Defined on subprogram entities. Set on subprogram helpers and also on +-- the indirect-call wrapper internally built for subprograms that have +-- class-wide preconditions. References the subprogram that has the +-- class-wide preconditions. -- Class_Wide_Type -- Defined in all type entities. For a tagged type or subtype, returns @@ -746,9 +757,9 @@ package Einfo is -- Corresponding_Record_Component -- Defined in components of a derived untagged record type, including --- discriminants. For a regular component or a girder discriminant, +-- discriminants. For a regular component or a stored discriminant, -- points to the corresponding component in the parent type. Set to --- Empty for a non-girder discriminant. It is used by the back end to +-- Empty for a non-stored discriminant. It is used by the back end to -- ensure the layout of the derived type matches that of the parent -- type when there is no representation clause on the derived type. @@ -818,7 +829,9 @@ package Einfo is -- a private type, then we obtain the declaration node denoted by the -- full type, i.e. the full type declaration node. Also note that for -- subprograms, this returns the {function,procedure}_specification, not --- the subprogram_declaration. +-- the subprogram_declaration. If the parent of an Itype is a type or +-- subtype declaration, we return the declaration node as for any other +-- type. For other Itypes, we return Empty. -- Default_Aspect_Component_Value [base type only] -- Defined in array types. Holds the static value specified in a @@ -1029,6 +1042,11 @@ package Einfo is -- associated with the tagged type. For an untagged record, contains -- No_Elist. +-- Dynamic_Call_Helper +-- Defined on subprogram entities. Set if the subprogram has class-wide +-- preconditions. Denotes the helper that evaluates at run time the +-- class-wide preconditions performing dispatching calls. + -- DTC_Entity -- Defined in function and procedure entities. Set to Empty unless -- the subprogram is dispatching in which case it references the @@ -2182,6 +2200,18 @@ package Einfo is -- "off" and indicates that all SPARK_Mode pragmas found within must -- be ignored. +-- Ignored_Class_Postconditions +-- Defined on subprogram entities. Set if the subprogram has class-wide +-- postconditions. Denotes the (and-then) expression built by merging +-- inherited ignored class-wide postconditions with its own ignored +-- class-wide postconditions. + +-- Ignored_Class_Preconditions +-- Defined on subprogram entities. Set if the subprogram has class-wide +-- preconditions. Denotes the (or-else) expression built by merging +-- inherited ignored class-wide preconditions with its own ignored +-- class-wide preconditions. + -- Implementation_Base_Type (synthesized) -- Applies to all entities. For types, similar to Base_Type, but never -- returns a private type when applied to a non-private type. Instead in @@ -2216,6 +2246,12 @@ package Einfo is -- is relocated to the corresponding package body, which must have a -- corresponding nonlimited with_clause. +-- Indirect_Call_Wrapper +-- Defined on subprogram entities. Set if the subprogram has class-wide +-- preconditions. Denotes the internal wrapper that checks preconditions +-- and invokes the subprogram body. Subp'Access points to the indirect +-- call wrapper if available. + -- Initialization_Statements -- Defined in constants and variables. For a composite object initialized -- with an aggregate that has been converted to a sequence of @@ -2393,6 +2429,11 @@ package Einfo is -- Is_Class_Wide_Type (synthesized) -- Applies to all entities, true for class wide types and subtypes +-- Is_Class_Wide_Wrapper +-- Defined in subprogram entities. Indicates that it has been created as +-- a wrapper in a generic/instance scenario involving a formal type and +-- a generic primitive operation when the actual is a class-wide type. + -- Is_Compilation_Unit -- Defined in all entities. Set if the entity is a package or subprogram -- entity for a compilation unit other than a subunit (since we treat @@ -2400,11 +2441,11 @@ package Einfo is -- parent, we do not consider them to be separate units for this flag). -- Is_Completely_Hidden --- Defined on discriminants. Only set on girder discriminants of --- untagged types. When set, the entity is a girder discriminant of a +-- Defined on discriminants. Only set on stored discriminants of +-- untagged types. When set, the entity is a stored discriminant of a -- derived untagged type which is not directly visible in the derived -- type because the derived type or one of its ancestors have renamed the --- discriminants in the root type. Note: there are girder discriminants +-- discriminants in the root type. Note: there are stored discriminants -- which are not Completely_Hidden (e.g. discriminants of a root type). -- Is_Composite_Type (synthesized) @@ -2507,6 +2548,11 @@ package Einfo is -- Applies to all entities. Set to indicate to the backend that this -- entity is associated with a dispatch table. +-- Is_Dispatch_Table_Wrapper +-- Applies to all entities. Set on wrappers built when the subprogram has +-- class-wide preconditions or class-wide postconditions affected by +-- overriding (AI12-0195). + -- Is_Dispatching_Operation -- Defined in all entities. Set for procedures, functions, generic -- procedures, and generic functions if the corresponding operation @@ -3652,7 +3698,7 @@ package Einfo is -- Next_Discriminant (synthesized) -- Applies to discriminants returned by First/Next_Discriminant. Returns --- the next language-defined (i.e. perhaps non-girder) discriminant by +-- the next language-defined (i.e. perhaps non-stored) discriminant by -- following the chain of declared entities as long as the kind of the -- entity corresponds to a discriminant. Note that the discriminants -- might be the only components of the record. Returns Empty if there @@ -3842,8 +3888,8 @@ package Einfo is -- Rec_Ext.Comp -> Rec_Ext.Parent. ... .Parent.Comp -- -- In base untagged types: --- Always points to itself except for non-girder discriminants, where --- it points to the girder discriminant it renames. +-- Always points to itself except for non-stored discriminants, where +-- it points to the stored discriminant it renames. -- -- In subtypes (tagged and untagged): -- Points to the component in the base type. @@ -4401,6 +4447,11 @@ package Einfo is -- Default_Scalar_Storage_Order (High_Order_First) was active at the time -- the record or array was declared and therefore applies to it. +-- Static_Call_Helper +-- Defined on subprogram entities. Set if the subprogram has class-wide +-- preconditions. Denotes the helper that evaluates at runtime the +-- class-wide preconditions performing static calls. + -- Static_Discrete_Predicate -- Defined in discrete types/subtypes with static predicates (with the -- two flags Has_Predicates and Has_Static_Predicate set). Set if the @@ -4878,6 +4929,7 @@ package Einfo is -- Is_Discrim_SO_Function -- Is_Discriminant_Check_Function -- Is_Dispatch_Table_Entity + -- Is_Dispatch_Table_Wrapper -- Is_Dispatching_Operation -- Is_Entry_Formal -- Is_Exported @@ -5484,7 +5536,14 @@ package Einfo is -- Linker_Section_Pragma -- Contract -- Import_Pragma (non-generic case only) - -- Class_Wide_Clone + -- Class_Postconditions + -- Class_Preconditions + -- Class_Preconditions_Subprogram + -- Dynamic_Call_Helper + -- Ignored_Class_Preconditions + -- Ignored_Class_Postconditions + -- Indirect_Call_Wrapper + -- Static_Call_Helper -- Protected_Subprogram (non-generic case only) -- SPARK_Pragma -- Original_Protected_Subprogram @@ -5508,6 +5567,7 @@ package Einfo is -- Ignore_SPARK_Mode_Pragmas -- Is_Abstract_Subprogram (non-generic case only) -- Is_Called (non-generic case only) + -- Is_Class_Wide_Wrapper -- Is_Constructor -- Is_CUDA_Kernel (non-generic case only) -- Is_DIC_Procedure (non-generic case only) @@ -5680,6 +5740,7 @@ package Einfo is -- Default_Expressions_Processed -- Has_Nested_Subprogram -- Ignore_SPARK_Mode_Pragmas + -- Is_Class_Wide_Wrapper -- Is_Elaboration_Checks_OK_Id -- Is_Elaboration_Warnings_OK_Id -- Is_Intrinsic_Subprogram @@ -5840,7 +5901,14 @@ package Einfo is -- Linker_Section_Pragma -- Contract -- Import_Pragma (non-generic case only) - -- Class_Wide_Clone + -- Class_Postconditions + -- Class_Preconditions + -- Class_Preconditions_Subprogram + -- Dynamic_Call_Helper + -- Ignored_Class_Preconditions + -- Ignored_Class_Postconditions + -- Indirect_Call_Wrapper + -- Static_Call_Helper -- Protected_Subprogram (non-generic case only) -- SPARK_Pragma -- Original_Protected_Subprogram @@ -5863,6 +5931,7 @@ package Einfo is -- Is_Abstract_Subprogram (non-generic case only) -- Is_Asynchronous -- Is_Called (non-generic case only) + -- Is_Class_Wide_Wrapper -- Is_Constructor -- Is_CUDA_Kernel -- Is_DIC_Procedure (non-generic case only) diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index 366df62..819d1ad 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -105,12 +105,15 @@ package Err_Vars is -- of the following global variables to appropriate values before making a -- call to one of the error message routines with a string containing the -- insertion character to get the value inserted in an appropriate format. + -- + -- Some of these are initialized below, because they are read before being + -- set by clients. Error_Msg_Col : Column_Number; -- Column for @ insertion character in message Error_Msg_Uint_1 : Uint; - Error_Msg_Uint_2 : Uint; + Error_Msg_Uint_2 : Uint := No_Uint; -- Uint values for ^ insertion characters in message -- WARNING: There is a matching C declaration of these variables in fe.h @@ -119,21 +122,21 @@ package Err_Vars is -- Source location for # insertion character in message Error_Msg_Name_1 : Name_Id; - Error_Msg_Name_2 : Name_Id; - Error_Msg_Name_3 : Name_Id; + Error_Msg_Name_2 : Name_Id := No_Name; + Error_Msg_Name_3 : Name_Id := No_Name; -- Name_Id values for % insertion characters in message Error_Msg_File_1 : File_Name_Type; - Error_Msg_File_2 : File_Name_Type; - Error_Msg_File_3 : File_Name_Type; + Error_Msg_File_2 : File_Name_Type := No_File; + Error_Msg_File_3 : File_Name_Type := No_File; -- File_Name_Type values for { insertion characters in message Error_Msg_Unit_1 : Unit_Name_Type; - Error_Msg_Unit_2 : Unit_Name_Type; + Error_Msg_Unit_2 : Unit_Name_Type := No_Unit_Name; -- Unit_Name_Type values for $ insertion characters in message Error_Msg_Node_1 : Node_Id; - Error_Msg_Node_2 : Node_Id; + Error_Msg_Node_2 : Node_Id := Empty; -- Node_Id values for & insertion characters in message Error_Msg_Warn : Boolean; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 99c7f9a..05a8266 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3602,15 +3602,9 @@ package body Errout is end if; -- The following assignment ensures that a second ampersand insertion - -- character will correspond to the Error_Msg_Node_2 parameter. We - -- suppress possible validity checks in case operating in -gnatVa mode, - -- and Error_Msg_Node_2 is not needed and has not been set. + -- character will correspond to the Error_Msg_Node_2 parameter. - declare - pragma Suppress (Range_Check); - begin - Error_Msg_Node_1 := Error_Msg_Node_2; - end; + Error_Msg_Node_1 := Error_Msg_Node_2; end Set_Msg_Insertion_Node; -------------------------------------- @@ -3790,15 +3784,9 @@ package body Errout is end if; -- The following assignment ensures that a second percent insertion - -- character will correspond to the Error_Msg_Unit_2 parameter. We - -- suppress possible validity checks in case operating in -gnatVa mode, - -- and Error_Msg_Unit_2 is not needed and has not been set. + -- character will correspond to the Error_Msg_Unit_2 parameter. - declare - pragma Suppress (Range_Check); - begin - Error_Msg_Unit_1 := Error_Msg_Unit_2; - end; + Error_Msg_Unit_1 := Error_Msg_Unit_2; end Set_Msg_Insertion_Unit_Name; ------------------ diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index a2cd3c3..9e67b92 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -1119,17 +1119,11 @@ package body Erroutc is end if; -- The following assignments ensure that the second and third { - -- insertion characters will correspond to the Error_Msg_File_2 and - -- Error_Msg_File_3 values and We suppress possible validity checks in - -- case operating in -gnatVa mode, and Error_Msg_File_2 or - -- Error_Msg_File_3 is not needed and has not been set. + -- insertion characters will correspond to the Error_Msg_File_2 + -- and Error_Msg_File_3 values. - declare - pragma Suppress (Range_Check); - begin - Error_Msg_File_1 := Error_Msg_File_2; - Error_Msg_File_2 := Error_Msg_File_3; - end; + Error_Msg_File_1 := Error_Msg_File_2; + Error_Msg_File_2 := Error_Msg_File_3; end Set_Msg_Insertion_File_Name; ----------------------------------- @@ -1299,16 +1293,10 @@ package body Erroutc is -- The following assignments ensure that the second and third percent -- insertion characters will correspond to the Error_Msg_Name_2 and - -- Error_Msg_Name_3 as required. We suppress possible validity checks in - -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed - -- and has not been set. + -- Error_Msg_Name_3 as required. - declare - pragma Suppress (Range_Check); - begin - Error_Msg_Name_1 := Error_Msg_Name_2; - Error_Msg_Name_2 := Error_Msg_Name_3; - end; + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; end Set_Msg_Insertion_Name; ------------------------------------ @@ -1334,16 +1322,10 @@ package body Erroutc is -- The following assignments ensure that the second and third % or %% -- insertion characters will correspond to the Error_Msg_Name_2 and - -- Error_Msg_Name_3 values and We suppress possible validity checks in - -- case operating in -gnatVa mode, and Error_Msg_Name_2 or - -- Error_Msg_Name_3 is not needed and has not been set. + -- Error_Msg_Name_3 values. - declare - pragma Suppress (Range_Check); - begin - Error_Msg_Name_1 := Error_Msg_Name_2; - Error_Msg_Name_2 := Error_Msg_Name_3; - end; + Error_Msg_Name_1 := Error_Msg_Name_2; + Error_Msg_Name_2 := Error_Msg_Name_3; end Set_Msg_Insertion_Name_Literal; ------------------------------------- @@ -1427,15 +1409,9 @@ package body Erroutc is end loop; -- The following assignment ensures that a second caret insertion - -- character will correspond to the Error_Msg_Uint_2 parameter. We - -- suppress possible validity checks in case operating in -gnatVa mode, - -- and Error_Msg_Uint_2 is not needed and has not been set. + -- character will correspond to the Error_Msg_Uint_2 parameter. - declare - pragma Suppress (Range_Check); - begin - Error_Msg_Uint_1 := Error_Msg_Uint_2; - end; + Error_Msg_Uint_1 := Error_Msg_Uint_2; end Set_Msg_Insertion_Uint; ----------------- diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 88303c9..71bad3c 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -124,7 +124,8 @@ package body Exp_Aggr is -- constants that are done in place. function Must_Slide - (Obj_Type : Entity_Id; + (Aggr : Node_Id; + Obj_Type : Entity_Id; Typ : Entity_Id) return Boolean; -- A static array aggregate in an object declaration can in most cases be -- expanded in place. The one exception is when the aggregate is given @@ -1776,7 +1777,7 @@ package body Exp_Aggr is if Nkind (Parent (N)) = N_Assignment_Statement and then Is_Array_Type (Comp_Typ) and then Present (Component_Associations (Expr_Q)) - and then Must_Slide (Comp_Typ, Etype (Expr_Q)) + and then Must_Slide (N, Comp_Typ, Etype (Expr_Q)) then Set_Expansion_Delayed (Expr_Q, False); Set_Analyzed (Expr_Q, False); @@ -5718,6 +5719,15 @@ package body Exp_Aggr is -- built directly into the target of the assignment it must be free -- of side effects. N is the LHS of an assignment. + procedure Two_Pass_Aggregate_Expansion (N : Node_Id); + -- If the aggregate consists only of iterated associations then the + -- aggregate is constructed in two steps: + -- a) Build an expression to compute the number of elements + -- generated by each iterator, and use the expression to allocate + -- the destination aggregate. + -- b) Generate the loops corresponding to each iterator to insert + -- the elements in their proper positions. + ---------------------------- -- Build_Constrained_Type -- ---------------------------- @@ -6334,6 +6344,197 @@ package body Exp_Aggr is end if; end Safe_Left_Hand_Side; + ---------------------------------- + -- Two_Pass_Aggregate_Expansion -- + ---------------------------------- + + procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Comp_Type : constant Entity_Id := Etype (N); + Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Index_Type : constant Entity_Id := Etype (First_Index (Etype (N))); + Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); + + Assoc : Node_Id := First (Component_Associations (N)); + Incr : Node_Id; + Iter : Node_Id; + New_Comp : Node_Id; + One_Loop : Node_Id; + + Size_Expr_Code : List_Id; + Insertion_Code : List_Id := New_List; + + begin + Size_Expr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Size_Id, + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + -- First pass: execute the iterators to count the number of elements + -- that will be generated. + + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Incr := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Size_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + One_Loop := Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => New_Copy_Tree (Iter)), + Statements => New_List (Incr)); + + Append (One_Loop, Size_Expr_Code); + Next (Assoc); + end loop; + + Insert_Actions (N, Size_Expr_Code); + + -- Build a constrained subtype with the calculated length + -- and declare the proper bounded aggregate object. + -- The index type is some discrete type, so the bounds of the + -- constructed array are computed as T'Val (T'Pos (ineger bound)); + + declare + Pos_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First))); + + Aggr_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (New_Copy_Tree (Pos_Lo))); + + -- Hi = Index_type'Pos (Lo + Size -1). + + Pos_Hi : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => New_Copy_Tree (Pos_Lo), + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Corresponding index value + + Aggr_Hi : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (New_Copy_Tree (Pos_Hi))); + + SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); + SubD : constant Node_Id := + Make_Subtype_Declaration (Loc, + Defining_Identifier => SubE, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Comp_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => + New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi))))); + + -- Create a temporary array of the above subtype which + -- will be used to capture the aggregate assignments. + + TmpD : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => TmpE, + Object_Definition => New_Occurrence_Of (SubE, Loc)); + begin + Insert_Actions (N, New_List (SubD, TmpD)); + end; + + -- Second pass: use the iterators to generate the elements of the + -- aggregate. Insertion index starts at Index_Type'First. We + -- assume that the second evaluation of each iterator generates + -- the same number of elements as the first pass, and consider + -- that the execution is erroneous (even if the RM does not state + -- this explicitly) if the number of elements generated differs + -- between first and second pass. + + Assoc := First (Component_Associations (N)); + + -- Initialize insertion position to first array component. + + Insertion_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Index_Id, + Object_Definition => + New_Occurrence_Of (Index_Type, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First))); + + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + New_Comp := Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (TmpE, Loc), + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc))), + Expression => New_Copy_Tree (Expression (Assoc))); + + -- Advance index position for insertion. + + Incr := Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Index_Id, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Succ, + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc)))); + + -- Add guard to skip last increment when upper bound is reached. + + Incr := Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Index_Id, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Last)), + Then_Statements => New_List (Incr)); + + One_Loop := Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => Copy_Separate_Tree (Iter)), + Statements => New_List (New_Comp, Incr)); + + Append (One_Loop, Insertion_Code); + Next (Assoc); + end loop; + + Insert_Actions (N, Insertion_Code); + + -- Depending on context this may not work for build-in-place + -- arrays ??? + + Rewrite (N, New_Occurrence_Of (TmpE, Loc)); + + end Two_Pass_Aggregate_Expansion; + -- Local variables Tmp : Entity_Id; @@ -6371,6 +6572,15 @@ package body Exp_Aggr is then return; + elsif Present (Component_Associations (N)) + and then Nkind (First (Component_Associations (N))) = + N_Iterated_Component_Association + and then + Present (Iterator_Specification (First (Component_Associations (N)))) + then + Two_Pass_Aggregate_Expansion (N); + return; + -- Do not attempt expansion if error already detected. We may reach this -- point in spite of previous errors when compiling with -gnatq, to -- force all possible errors (this is the usual ACATS mode). @@ -6657,7 +6867,7 @@ package body Exp_Aggr is and then Parent_Kind = N_Object_Declaration and then Present (Expression (Parent_Node)) and then not - Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ) + Must_Slide (N, Etype (Defining_Identifier (Parent_Node)), Typ) and then not Is_Bit_Packed_Array (Typ) then In_Place_Assign_OK_For_Declaration := True; @@ -7038,6 +7248,9 @@ package body Exp_Aggr is -- or Element_Association with non-static bounds, build an expression -- to be used as the allocated size of the container. This may be an -- overestimate if a filter is present, but is a safe approximation. + -- If bounds are dynamic the aggregate is created in two passes, and + -- the first generates a loop for the sole purpose of computing the + -- number of elements that will be generated on the seocnd pass. procedure Expand_Iterated_Component (Comp : Node_Id); -- Handle iterated_component_association and iterated_Element @@ -7185,7 +7398,11 @@ package body Exp_Aggr is return Build_Siz_Exp (First (Discrete_Choices (Comp))); elsif Nkind (Comp) = N_Iterated_Element_Association then - return -1; -- ??? build expression for size of the domain + return -1; + + -- ??? Need to create code for a loop and add to generated code, + -- as is done for array aggregates with iterated element + -- associations, instead of using Append operations. else return -1; @@ -7217,7 +7434,7 @@ package body Exp_Aggr is if Present (Iterator_Specification (Comp)) then - -- Either an Iterator_Specification of a Loop_Parameter_ + -- Either an Iterator_Specification or a Loop_Parameter_ -- Specification is present. L_Iteration_Scheme := @@ -8046,7 +8263,7 @@ package body Exp_Aggr is Discr : Entity_Id; Decl : Node_Id; Num_Disc : Nat := 0; - Num_Gird : Nat := 0; + Num_Stor : Nat := 0; -- Start of processing for Generate_Aggregate_For_Derived_Type @@ -8082,13 +8299,13 @@ package body Exp_Aggr is Discr := First_Stored_Discriminant (Base_Type (Typ)); while Present (Discr) loop - Num_Gird := Num_Gird + 1; + Num_Stor := Num_Stor + 1; Next_Stored_Discriminant (Discr); end loop; -- Case of more stored discriminants than new discriminants - if Num_Gird > Num_Disc then + if Num_Stor > Num_Disc then -- Create a proper subtype of the parent type, which is the -- proper implementation type for the aggregate, and convert @@ -9411,13 +9628,16 @@ package body Exp_Aggr is ---------------- function Must_Slide - (Obj_Type : Entity_Id; + (Aggr : Node_Id; + Obj_Type : Entity_Id; Typ : Entity_Id) return Boolean is begin -- No sliding if the type of the object is not established yet, if it is -- an unconstrained type whose actual subtype comes from the aggregate, - -- or if the two types are identical. + -- or if the two types are identical. If the aggregate contains only + -- an Others_Clause it gets its type from the context and no sliding + -- is involved either. if not Is_Array_Type (Obj_Type) then return False; @@ -9428,8 +9648,13 @@ package body Exp_Aggr is elsif Typ = Obj_Type then return False; + elsif Is_Others_Aggregate (Aggr) then + return False; + else -- Sliding can only occur along the first dimension + -- If any the bounds of non-static sliding is required + -- to force potential range checks. declare Bounds1 : constant Range_Nodes := @@ -9443,7 +9668,8 @@ package body Exp_Aggr is not Is_OK_Static_Expression (Bounds1.Last) or else not Is_OK_Static_Expression (Bounds2.Last) then - return False; + return True; + else return Expr_Value (Bounds1.First) /= Expr_Value (Bounds2.First) or else diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c962c2a..096671f 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -165,8 +165,7 @@ package body Exp_Attr is -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args -- have already been converted to the floating-point type for which Pkg was -- instantiated. The Nam argument is the relevant attribute processing - -- routine to be called. This is the same as the attribute name, except in - -- the Unaligned_Valid case. + -- routine to be called. This is the same as the attribute name. procedure Expand_Fpt_Attribute_R (N : Node_Id); -- This procedure expands a call to a floating-point attribute function @@ -2216,6 +2215,20 @@ package body Exp_Attr is if Is_Access_Protected_Subprogram_Type (Btyp) then Expand_Access_To_Protected_Op (N, Pref, Typ); + -- If prefix is a subprogram that has class-wide preconditions and + -- an indirect-call wrapper (ICW) of such subprogram is available + -- then replace the prefix by the ICW. + + elsif Is_Access_Subprogram_Type (Btyp) + and then Is_Entity_Name (Pref) + and then Present (Class_Preconditions (Entity (Pref))) + and then Present (Indirect_Call_Wrapper (Entity (Pref))) + then + Rewrite (Pref, + New_Occurrence_Of + (Indirect_Call_Wrapper (Entity (Pref)), Loc)); + Analyze_And_Resolve (N, Typ); + -- If prefix is a type name, this is a reference to the current -- instance of the type, within its initialization procedure. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 45d5baf..418306f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Contracts; use Contracts; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -5352,10 +5353,66 @@ package body Exp_Ch3 is ------------------------------- procedure Expand_Freeze_Record_Type (N : Node_Id) is + + procedure Build_Class_Condition_Subprograms (Typ : Entity_Id); + -- Create internal subprograms of Typ primitives that have class-wide + -- preconditions or postconditions; they are invoked by the caller to + -- evaluate the conditions. + procedure Build_Variant_Record_Equality (Typ : Entity_Id); -- Create An Equality function for the untagged variant record Typ and -- attach it to the TSS list. + procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id); + -- Register dispatch-table wrappers in the dispatch table of Typ + + --------------------------------------- + -- Build_Class_Condition_Subprograms -- + --------------------------------------- + + procedure Build_Class_Condition_Subprograms (Typ : Entity_Id) is + Prim_List : constant Elist_Id := Primitive_Operations (Typ); + Prim_Elmt : Elmt_Id := First_Elmt (Prim_List); + Prim : Entity_Id; + + begin + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- Primitive with class-wide preconditions + + if Comes_From_Source (Prim) + and then Has_Significant_Contract (Prim) + and then + (Present (Class_Preconditions (Prim)) + or else Present (Ignored_Class_Preconditions (Prim))) + then + if Expander_Active then + Make_Class_Precondition_Subps (Prim); + end if; + + -- Wrapper of a primitive that has or inherits class-wide + -- preconditions. + + elsif Is_Primitive_Wrapper (Prim) + and then + (Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Prim, + Kind => Class_Precondition)) + or else + Present (Nearest_Class_Condition_Subprogram + (Spec_Id => Prim, + Kind => Ignored_Class_Precondition))) + then + if Expander_Active then + Make_Class_Precondition_Subps (Prim); + end if; + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Build_Class_Condition_Subprograms; + ----------------------------------- -- Build_Variant_Record_Equality -- ----------------------------------- @@ -5417,6 +5474,27 @@ package body Exp_Ch3 is end if; end Build_Variant_Record_Equality; + -------------------------------------- + -- Register_Dispatch_Table_Wrappers -- + -------------------------------------- + + procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id) is + Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ)); + Subp : Entity_Id; + + begin + while Present (Elmt) loop + Subp := Node (Elmt); + + if Is_Dispatch_Table_Wrapper (Subp) then + Append_Freeze_Actions (Typ, + Register_Primitive (Sloc (Subp), Subp)); + end if; + + Next_Elmt (Elmt); + end loop; + end Register_Dispatch_Table_Wrappers; + -- Local variables Typ : constant Node_Id := Entity (N); @@ -5666,6 +5744,13 @@ package body Exp_Ch3 is if not Building_Static_DT (Typ) then Append_Freeze_Actions (Typ, Make_DT (Typ)); + + -- Register dispatch table wrappers in the dispatch table. + -- It could not be done when these wrappers were built + -- because, at that stage, the dispatch table was not + -- available. + + Register_Dispatch_Table_Wrappers (Typ); end if; end if; @@ -5857,6 +5942,13 @@ package body Exp_Ch3 is end loop; end; end if; + + -- Build internal subprograms of primitives with class-wide + -- pre/postconditions. + + if Is_Tagged_Type (Typ) then + Build_Class_Condition_Subprograms (Typ); + end if; end Expand_Freeze_Record_Type; ------------------------------------ diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 497a52b..8dcfa85 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -4703,7 +4704,7 @@ package body Exp_Ch4 is else Set_Procedure_To_Call (N, - Find_Prim_Op (Etype (Pool), Name_Allocate)); + Find_Storage_Op (Etype (Pool), Name_Allocate)); end if; end if; end if; @@ -6253,6 +6254,46 @@ package body Exp_Ch4 is return; end if; + -- For the sake of GNATcoverage, generate an intermediate temporary in + -- the case where the if-expression is a condition in an outer decision, + -- in order to make sure that no branch is shared between the decisions. + + elsif Opt.Suppress_Control_Flow_Optimizations + and then Nkind (Original_Node (Parent (N))) in N_Case_Expression + | N_Case_Statement + | N_If_Expression + | N_If_Statement + | N_Goto_When_Statement + | N_Loop_Statement + | N_Return_When_Statement + | N_Short_Circuit + then + declare + Cnn : constant Entity_Id := Make_Temporary (Loc, 'C'); + Acts : List_Id; + + begin + -- Generate: + -- do + -- Cnn : constant Typ := N; + -- in Cnn end + + Acts := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (N))); + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => New_Occurrence_Of (Cnn, Loc), + Actions => Acts)); + + Analyze_And_Resolve (N, Typ); + return; + end; + -- If no actions then no expansion needed, gigi will handle it using the -- same approach as a C conditional expression. @@ -6870,7 +6911,6 @@ package body Exp_Ch4 is if Ada_Version >= Ada_2012 and then Is_Acc and then Ekind (Ltyp) = E_Anonymous_Access_Type - and then not No_Dynamic_Accessibility_Checks_Enabled (Lop) then declare Expr_Entity : Entity_Id := Empty; @@ -6887,11 +6927,26 @@ package body Exp_Ch4 is end if; end if; + -- When restriction No_Dynamic_Accessibility_Checks is in + -- effect, expand the membership test to a static value + -- since we cannot rely on dynamic levels. + + if No_Dynamic_Accessibility_Checks_Enabled (Lop) then + if Static_Accessibility_Level + (Lop, Object_Decl_Level) + > Type_Access_Level (Rtyp) + then + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + end if; + Analyze_And_Resolve (N, Restyp); + -- If a conversion of the anonymous access value to the -- tested type would be illegal, then the result is False. - if not Valid_Conversion - (Lop, Rtyp, Lop, Report_Errs => False) + elsif not Valid_Conversion + (Lop, Rtyp, Lop, Report_Errs => False) then Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); Analyze_And_Resolve (N, Restyp); @@ -7047,11 +7102,123 @@ package body Exp_Ch4 is -------------------------------- procedure Expand_N_Indexed_Component (N : Node_Id) is + + Wild_Reads_May_Have_Bad_Side_Effects : Boolean + renames Validity_Check_Subscripts; + -- This Boolean needs to be True if reading from a bad address can + -- have a bad side effect (e.g., a segmentation fault that is not + -- transformed into a Storage_Error exception, or interactions with + -- memory-mapped I/O) that needs to be prevented. This refers to the + -- act of reading itself, not to any damage that might be caused later + -- by making use of whatever value was read. We assume here that + -- Validity_Check_Subscripts meets this requirement, but introduce + -- this declaration in order to document this assumption. + + function Is_Renamed_Variable_Name (N : Node_Id) return Boolean; + -- Returns True if the given name occurs as part of the renaming + -- of a variable. In this case, the indexing operation should be + -- treated as a write, rather than a read, with respect to validity + -- checking. This is because the renamed variable can later be + -- written to. + + function Type_Requires_Subscript_Validity_Checks_For_Reads + (Typ : Entity_Id) return Boolean; + -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing + -- into an array of characters in order to read an element, it is ok + -- if an invalid index value goes undetected. But if it is an array of + -- pointers or an array of tasks, the consequences of such a read are + -- potentially more severe and so we want to detect an invalid index + -- value. This function captures that distinction; this is intended to + -- be consistent with the "but does not by itself lead to erroneous + -- ... execution" rule of RM 13.9.1(11). + + ------------------------------ + -- Is_Renamed_Variable_Name -- + ------------------------------ + + function Is_Renamed_Variable_Name (N : Node_Id) return Boolean is + Rover : Node_Id := N; + begin + if Is_Variable (N) then + loop + declare + Rover_Parent : constant Node_Id := Parent (Rover); + begin + case Nkind (Rover_Parent) is + when N_Object_Renaming_Declaration => + return Rover = Name (Rover_Parent); + + when N_Indexed_Component + | N_Slice + | N_Selected_Component + => + exit when Rover /= Prefix (Rover_Parent); + Rover := Rover_Parent; + + -- No need to check for qualified expressions or type + -- conversions here, mostly because of the Is_Variable + -- test. It is possible to have a view conversion for + -- which Is_Variable yields True and which occurs as + -- part of an object renaming, but only if the type is + -- tagged; in that case this function will not be called. + + when others => + exit; + end case; + end; + end loop; + end if; + return False; + end Is_Renamed_Variable_Name; + + ------------------------------------------------------- + -- Type_Requires_Subscript_Validity_Checks_For_Reads -- + ------------------------------------------------------- + + function Type_Requires_Subscript_Validity_Checks_For_Reads + (Typ : Entity_Id) return Boolean + is + -- a shorter name for recursive calls + function Needs_Check (Typ : Entity_Id) return Boolean renames + Type_Requires_Subscript_Validity_Checks_For_Reads; + begin + if Is_Access_Type (Typ) + or else Is_Tagged_Type (Typ) + or else Is_Concurrent_Type (Typ) + or else (Is_Array_Type (Typ) + and then Needs_Check (Component_Type (Typ))) + or else (Is_Scalar_Type (Typ) + and then Has_Aspect (Typ, Aspect_Default_Value)) + then + return True; + end if; + + if Is_Record_Type (Typ) then + declare + Comp : Entity_Id := First_Component_Or_Discriminant (Typ); + begin + while Present (Comp) loop + if Needs_Check (Etype (Comp)) then + return True; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end; + end if; + + return False; + end Type_Requires_Subscript_Validity_Checks_For_Reads; + + -- Local constants + Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); P : constant Node_Id := Prefix (N); T : constant Entity_Id := Etype (P); + -- Start of processing for Expand_N_Indexed_Component + begin -- A special optimization, if we have an indexed component that is -- selecting from a slice, then we can eliminate the slice, since, for @@ -7101,11 +7268,67 @@ package body Exp_Ch4 is -- Generate index and validity checks - Generate_Index_Checks (N); + declare + Dims_Checked : Dimension_Set (Dimensions => + (if Is_Array_Type (T) + then Number_Dimensions (T) + else 1)); + -- Dims_Checked is used to avoid generating two checks (one in + -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks) + -- for the same index value in cases where the index check eliminates + -- the need for the validity check. The Is_Array_Type test avoids + -- cascading errors. - if Validity_Checks_On and then Validity_Check_Subscripts then - Apply_Subscript_Validity_Checks (N); - end if; + begin + Generate_Index_Checks (N, Checks_Generated => Dims_Checked); + + if Validity_Checks_On + and then (Validity_Check_Subscripts + or else Wild_Reads_May_Have_Bad_Side_Effects + or else Type_Requires_Subscript_Validity_Checks_For_Reads + (Typ) + or else Is_Renamed_Variable_Name (N)) + then + if Validity_Check_Subscripts then + -- If we index into an array with an uninitialized variable + -- and we generate an index check that passes at run time, + -- passing that check does not ensure that the variable is + -- valid (although it does in the common case where the + -- object's subtype matches the index subtype). + -- Consider an uninitialized variable with subtype 1 .. 10 + -- used to index into an array with bounds 1 .. 20 when the + -- value of the uninitialized variable happens to be 15. + -- The index check will succeed but the variable is invalid. + -- If Validity_Check_Subscripts is True then we need to + -- ensure validity, so we adjust Dims_Checked accordingly. + Dims_Checked.Elements := (others => False); + + elsif Is_Array_Type (T) then + -- We are only adding extra validity checks here to + -- deal with uninitialized variables (but this includes + -- assigning one uninitialized variable to another). Other + -- ways of producing invalid objects imply erroneousness, so + -- the compiler can do whatever it wants for those cases. + -- If an index type has the Default_Value aspect specified, + -- then we don't have to worry about the possibility of an + -- uninitialized variable, so no need for these extra + -- validity checks. + + declare + Idx : Node_Id := First_Index (T); + begin + for No_Check_Needed of Dims_Checked.Elements loop + No_Check_Needed := No_Check_Needed + or else Has_Aspect (Etype (Idx), Aspect_Default_Value); + Next_Index (Idx); + end loop; + end; + end if; + + Apply_Subscript_Validity_Checks + (N, No_Check_Needed => Dims_Checked); + end if; + end; -- If selecting from an array with atomic components, and atomic sync -- is not suppressed for this array type, set atomic sync flag. @@ -8569,8 +8792,7 @@ package body Exp_Ch4 is -- f'Machine (expr) to eliminate surprise from extra precision. if Is_Floating_Point_Type (Typl) - and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference - and then Attribute_Name (Original_Node (Lhs)) = Name_Result + and then Is_Attribute_Result (Original_Node (Lhs)) then -- Stick in the Typ'Machine call if not already there @@ -11338,7 +11560,7 @@ package body Exp_Ch4 is then Par := Parent (Par); - -- Any other case is not what we are looking for + -- Any other case is not what we are looking for else return False; @@ -11374,7 +11596,7 @@ package body Exp_Ch4 is -- Local variables - Pref : constant Node_Id := Prefix (N); + Pref : constant Node_Id := Prefix (N); -- Start of processing for Expand_N_Slice @@ -11400,7 +11622,7 @@ package body Exp_Ch4 is -- situation correctly in the assignment statement expansion). -- 2. Prefix of indexed component (the slide is optimized away in this - -- case, see the start of Expand_N_Slice.) + -- case, see the start of Expand_N_Indexed_Component.) -- 3. Object renaming declaration, since we want the name of the -- slice, not the value. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 9827326..21ac2a2 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -31,7 +31,6 @@ with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; -with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -3365,6 +3364,30 @@ package body Exp_Ch5 is renames Pattern_Match; -- convenient rename for recursive calls + function Indexed_Element (Idx : Pos) return Node_Id; + -- Returns the Nth (well, ok, the Idxth) element of Object + + --------------------- + -- Indexed_Element -- + --------------------- + + function Indexed_Element (Idx : Pos) return Node_Id is + Obj_Index : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_First, + Prefix => New_Copy_Tree (Object)), + Right_Opnd => + Make_Integer_Literal (Loc, Idx - 1)); + begin + return Make_Indexed_Component (Loc, + Prefix => New_Copy_Tree (Object), + Expressions => New_List (Obj_Index)); + end Indexed_Element; + + -- Start of processing for Pattern_Match + begin if Choice_Index /= 0 and not Suppress_Choice_Index_Update then pragma Assert (Present (Choice_Index_Decl)); @@ -3399,16 +3422,51 @@ package body Exp_Ch5 is case Nkind (Pattern) is when N_Aggregate => - return Result : Node_Id := - New_Occurrence_Of (Standard_True, Loc) - do + declare + Result : Node_Id; + begin if Is_Array_Type (Etype (Pattern)) then - -- Calling Error_Msg_N during expansion is usually a - -- mistake but is ok for an "unimplemented" message. - Error_Msg_N - ("array-valued case choices unimplemented", - Pattern); - return; + + -- Nonpositional aggregates currently unimplemented. + -- We flag that case during analysis, so an assertion + -- is ok here. + -- + pragma Assert + (not Is_Non_Empty_List + (Component_Associations (Pattern))); + + declare + Agg_Length : constant Node_Id := + Make_Integer_Literal (Loc, + List_Length (Expressions (Pattern))); + + Obj_Length : constant Node_Id := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Copy_Tree (Object)); + begin + Result := Make_Op_Eq (Loc, + Left_Opnd => Obj_Length, + Right_Opnd => Agg_Length); + end; + + declare + Expr : Node_Id := First (Expressions (Pattern)); + Idx : Pos := 1; + begin + while Present (Expr) loop + Result := + Make_And_Then (Loc, + Left_Opnd => Result, + Right_Opnd => + PM (Pattern => Expr, + Object => Indexed_Element (Idx))); + Next (Expr); + Idx := Idx + 1; + end loop; + end; + + return Result; end if; -- positional notation should have been normalized @@ -3425,6 +3483,8 @@ package body Exp_Ch5 is Selector_Name => New_Occurrence_Of (Entity (Choice), Loc))); begin + Result := New_Occurrence_Of (Standard_True, Loc); + while Present (Component_Assoc) loop Choice := First (Choices (Component_Assoc)); while Present (Choice) loop @@ -3530,27 +3590,82 @@ package body Exp_Ch5 is Next (Component_Assoc); end loop; end; + return Result; + end; + + when N_String_Literal => + return Result : Node_Id do + declare + Char_Type : constant Entity_Id := + Root_Type (Component_Type (Etype (Pattern))); + + -- If the component type is not a standard character + -- type then this string lit should have already been + -- transformed into an aggregate in + -- Resolve_String_Literal. + -- + pragma Assert (Is_Standard_Character_Type (Char_Type)); + + Str : constant String_Id := Strval (Pattern); + Strlen : constant Nat := String_Length (Str); + + Lit_Length : constant Node_Id := + Make_Integer_Literal (Loc, Strlen); + + Obj_Length : constant Node_Id := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Length, + Prefix => New_Copy_Tree (Object)); + begin + Result := Make_Op_Eq (Loc, + Left_Opnd => Obj_Length, + Right_Opnd => Lit_Length); + + for Idx in 1 .. Strlen loop + declare + C : constant Char_Code := + Get_String_Char (Str, Idx); + Obj_Element : constant Node_Id := + Indexed_Element (Idx); + Char_Lit : Node_Id; + begin + Set_Character_Literal_Name (C); + Char_Lit := + Make_Character_Literal (Loc, + Chars => Name_Find, + Char_Literal_Value => UI_From_CC (C)); + + Result := + Make_And_Then (Loc, + Left_Opnd => Result, + Right_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => Obj_Element, + Right_Opnd => Char_Lit)); + end; + end loop; + end; end return; when N_Qualified_Expression => - -- Make a copy for one of the two uses of Object; the choice - -- of where to use the original and where to use the copy - -- is arbitrary. - return Make_And_Then (Loc, Left_Opnd => Make_In (Loc, Left_Opnd => New_Copy_Tree (Object), Right_Opnd => New_Copy_Tree (Subtype_Mark (Pattern))), Right_Opnd => PM (Pattern => Expression (Pattern), - Object => Object)); + Object => New_Copy_Tree (Object))); when N_Identifier | N_Expanded_Name => if Is_Type (Entity (Pattern)) then return Make_In (Loc, - Left_Opnd => Object, + Left_Opnd => New_Copy_Tree (Object), Right_Opnd => New_Occurrence_Of (Entity (Pattern), Loc)); + elsif Ekind (Entity (Pattern)) = E_Constant then + return PM (Pattern => + Expression (Parent (Entity (Pattern))), + Object => Object); end if; when N_Others_Choice => diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7717fa7..ce0bb80 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -73,8 +73,10 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; +with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -4065,7 +4067,7 @@ package body Exp_Ch6 is end; end if; - -- If the formal is class wide and the actual is an aggregate, force + -- If the formal is class-wide and the actual is an aggregate, force -- evaluation so that the back end who does not know about class-wide -- type, does not generate a temporary of the wrong size. @@ -4250,6 +4252,16 @@ package body Exp_Ch6 is Expand_Interface_Actuals (Call_Node); end if; + -- Install class-wide preconditions runtime check when this is a + -- dispatching primitive that has or inherits class-wide preconditions; + -- otherwise no runtime check is installed. + + if Nkind (Call_Node) in N_Subprogram_Call + and then Is_Dispatching_Operation (Subp) + then + Install_Class_Preconditions_Check (Call_Node); + end if; + -- Deals with Dispatch_Call if we still have a call, before expanding -- extra actuals since this will be done on the re-analysis of the -- dispatching call. Note that we do not try to shorten the actual list @@ -4380,6 +4392,7 @@ package body Exp_Ch6 is -- the current subprogram is called. if Is_Subprogram (Subp) + and then not Is_Ignored_Ghost_Entity (Subp) and then Same_Or_Aliased_Subprograms (Subp, Current_Scope) then Check_Subprogram_Variant; @@ -7855,18 +7868,6 @@ package body Exp_Ch6 is -- returned type may not be known yet (for private types). Compute_Returns_By_Ref (Subp); - - -- When freezing a null procedure, analyze its delayed aspects now - -- because we may not have reached the end of the declarative list when - -- delayed aspects are normally analyzed. This ensures that dispatching - -- calls are properly rewritten when the generated _Postcondition - -- procedure is analyzed in the null procedure body. - - if Nkind (Parent (Subp)) = N_Procedure_Specification - and then Null_Present (Parent (Subp)) - then - Analyze_Entry_Or_Subprogram_Contract (Subp); - end if; end Freeze_Subprogram; -------------------------- @@ -8101,6 +8102,367 @@ package body Exp_Ch6 is end if; end Insert_Post_Call_Actions; + --------------------------------------- + -- Install_Class_Preconditions_Check -- + --------------------------------------- + + procedure Install_Class_Preconditions_Check (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + + function Build_Dynamic_Check_Helper_Call return Node_Id; + -- Build call to the helper runtime function of the nearest ancestor + -- of the target subprogram that dynamically evaluates the merged + -- or-else preconditions. + + function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id; + -- Build message associated with the class-wide precondition of Subp_Id + -- indicating the call that caused it. + + function Build_Static_Check_Helper_Call return Node_Id; + -- Build call to the helper runtime function of the nearest ancestor + -- of the target subprogram that dynamically evaluates the merged + -- or-else preconditions. + + function Class_Preconditions_Subprogram + (Spec_Id : Entity_Id; + Dynamic : Boolean) return Node_Id; + -- Return the nearest ancestor of Spec_Id defining a helper function + -- that evaluates a combined or-else expression containing all the + -- inherited class-wide preconditions; Dynamic enables searching for + -- the helper that dynamically evaluates preconditions using dispatching + -- calls; if False it searches for the helper that statically evaluates + -- preconditions; return Empty when not available (which means that no + -- preconditions check is required). + + ------------------------------------- + -- Build_Dynamic_Check_Helper_Call -- + ------------------------------------- + + function Build_Dynamic_Check_Helper_Call return Node_Id is + Spec_Id : constant Entity_Id := Entity (Name (Call_Node)); + CW_Subp : constant Entity_Id := + Class_Preconditions_Subprogram (Spec_Id, + Dynamic => True); + Helper_Id : constant Entity_Id := + Dynamic_Call_Helper (CW_Subp); + Actuals : constant List_Id := New_List; + A : Node_Id := First_Actual (Call_Node); + F : Entity_Id := First_Formal (Helper_Id); + + begin + while Present (A) loop + + -- Ensure that the evaluation of the actuals will not produce + -- side effects. + + Remove_Side_Effects (A); + + Append_To (Actuals, New_Copy_Tree (A)); + Next_Formal (F); + Next_Actual (A); + end loop; + + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Helper_Id, Loc), + Parameter_Associations => Actuals); + end Build_Dynamic_Check_Helper_Call; + + ------------------------- + -- Build_Error_Message -- + ------------------------- + + function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id is + + procedure Append_Message + (Id : Entity_Id; + Is_First : in out Boolean); + -- Build the fragment of the message associated with subprogram Id; + -- Is_First facilitates identifying continuation messages. + + -------------------- + -- Append_Message -- + -------------------- + + procedure Append_Message + (Id : Entity_Id; + Is_First : in out Boolean) + is + Prag : constant Node_Id := Get_Class_Wide_Pragma (Id, + Pragma_Precondition); + Msg : Node_Id; + Str_Id : String_Id; + + begin + if No (Prag) or else Is_Ignored (Prag) then + return; + end if; + + Msg := Expression (Last (Pragma_Argument_Associations (Prag))); + Str_Id := Strval (Msg); + + if Is_First then + Is_First := False; + + Append (Global_Name_Buffer, Strval (Msg)); + + if Id /= Subp_Id + and then Name_Buffer (1 .. 19) = "failed precondition" + then + Insert_Str_In_Name_Buffer ("inherited ", 8); + end if; + + else + declare + Str : constant String := To_String (Str_Id); + From_Idx : Integer; + + begin + Append (Global_Name_Buffer, ASCII.LF); + Append (Global_Name_Buffer, " or "); + + From_Idx := Name_Len; + Append (Global_Name_Buffer, Str_Id); + + if Str (1 .. 19) = "failed precondition" then + Insert_Str_In_Name_Buffer ("inherited ", From_Idx + 8); + end if; + end; + end if; + end Append_Message; + + -- Local variables + + Str_Loc : constant String := Build_Location_String (Loc); + Subps : constant Subprogram_List := + Inherited_Subprograms (Subp_Id); + Is_First : Boolean := True; + + -- Start of processing for Build_Error_Message + + begin + Name_Len := 0; + Append_Message (Subp_Id, Is_First); + + for Index in Subps'Range loop + Append_Message (Subps (Index), Is_First); + end loop; + + if Present (Controlling_Argument (Call_Node)) then + Append (Global_Name_Buffer, " in dispatching call at "); + else + Append (Global_Name_Buffer, " in call at "); + end if; + + Append (Global_Name_Buffer, Str_Loc); + + return Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); + end Build_Error_Message; + + ------------------------------------ + -- Build_Static_Check_Helper_Call -- + ------------------------------------ + + function Build_Static_Check_Helper_Call return Node_Id is + Actuals : constant List_Id := New_List; + A : Node_Id; + Helper_Id : Entity_Id; + F : Entity_Id; + CW_Subp : Entity_Id; + Spec_Id : constant Entity_Id := Entity (Name (Call_Node)); + + begin + -- The target is the wrapper built to support inheriting body but + -- overriding pre/postconditions (AI12-0195). + + if Is_Dispatch_Table_Wrapper (Spec_Id) then + CW_Subp := Spec_Id; + + -- Common case + + else + CW_Subp := Class_Preconditions_Subprogram (Spec_Id, + Dynamic => False); + end if; + + Helper_Id := Static_Call_Helper (CW_Subp); + + F := First_Formal (Helper_Id); + A := First_Actual (Call_Node); + while Present (A) loop + + -- Ensure that the evaluation of the actuals will not produce + -- side effects. + + Remove_Side_Effects (A); + + if Is_Controlling_Actual (A) + and then Etype (F) /= Etype (A) + then + Append_To (Actuals, + Make_Unchecked_Type_Conversion (Loc, + New_Occurrence_Of (Etype (F), Loc), + New_Copy_Tree (A))); + else + Append_To (Actuals, New_Copy_Tree (A)); + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Helper_Id, Loc), + Parameter_Associations => Actuals); + end Build_Static_Check_Helper_Call; + + ------------------------------------ + -- Class_Preconditions_Subprogram -- + ------------------------------------ + + function Class_Preconditions_Subprogram + (Spec_Id : Entity_Id; + Dynamic : Boolean) return Node_Id + is + Subp_Id : constant Entity_Id := Ultimate_Alias (Spec_Id); + + begin + -- Prevent cascaded errors + + if not Is_Dispatching_Operation (Subp_Id) then + return Empty; + + -- No need to search if this subprogram has the helper we are + -- searching + + elsif Dynamic then + if Present (Dynamic_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + else + if Present (Static_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + end if; + + -- Process inherited subprograms looking for class-wide + -- preconditions. + + declare + Subps : constant Subprogram_List := + Inherited_Subprograms (Subp_Id); + Subp_Id : Entity_Id; + + begin + for Index in Subps'Range loop + Subp_Id := Subps (Index); + + if Present (Alias (Subp_Id)) then + Subp_Id := Ultimate_Alias (Subp_Id); + end if; + + -- Wrappers of class-wide pre/postconditions reference the + -- parent primitive that has the inherited contract. + + if Is_Wrapper (Subp_Id) + and then Present (LSP_Subprogram (Subp_Id)) + then + Subp_Id := LSP_Subprogram (Subp_Id); + end if; + + if Dynamic then + if Present (Dynamic_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + else + if Present (Static_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + end if; + end loop; + end; + + return Empty; + end Class_Preconditions_Subprogram; + + -- Local variables + + Dynamic_Check : constant Boolean := + Present (Controlling_Argument (Call_Node)); + Class_Subp : Entity_Id; + Cond : Node_Id; + Subp : Entity_Id; + + -- Start of processing for Install_Class_Preconditions_Check + + begin + -- Do not expand the check if we are compiling under restriction + -- No_Dispatching_Calls; the semantic analyzer has previously + -- notified the violation of this restriction. + + if Dynamic_Check + and then Restriction_Active (No_Dispatching_Calls) + then + return; + + -- Class-wide precondition check not needed in interface thunks since + -- they are installed in the dispatching call that caused invoking the + -- thunk. + + elsif Is_Thunk (Current_Scope) then + return; + end if; + + Subp := Entity (Name (Call_Node)); + + -- No check needed for this subprogram call if no class-wide + -- preconditions apply (or if the unique available preconditions + -- are ignored preconditions). + + Class_Subp := Class_Preconditions_Subprogram (Subp, Dynamic_Check); + + if No (Class_Subp) + or else No (Class_Preconditions (Class_Subp)) + then + return; + end if; + + -- Build and install the check + + if Dynamic_Check then + Cond := Build_Dynamic_Check_Helper_Call; + else + Cond := Build_Static_Check_Helper_Call; + end if; + + if Exception_Locations_Suppressed then + Insert_Action (Call_Node, + Make_If_Statement (Loc, + Condition => Make_Op_Not (Loc, Cond), + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Assert_Failure), Loc))))); + + -- Failed check with message indicating the failed precondition and the + -- call that caused it. + + else + Insert_Action (Call_Node, + Make_If_Statement (Loc, + Condition => Make_Op_Not (Loc, Cond), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => + New_List (Build_Error_Message (Subp)))))); + end if; + end Install_Class_Preconditions_Check; + ----------------------------------- -- Is_Build_In_Place_Result_Type -- ----------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 76cec4d..196f7e6 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -121,6 +121,9 @@ package Exp_Ch6 is -- The returned node is the root of the procedure body which will replace -- the original function body, which is not needed for the C program. + procedure Install_Class_Preconditions_Check (Call_Node : Node_Id); + -- Install check of class-wide preconditions on the caller. + function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 8d08ff1..71cad98 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -486,11 +486,11 @@ package body Exp_Ch7 is function Make_Deep_Proc (Prim : Final_Primitives; Typ : Entity_Id; - Stmts : List_Id) return Node_Id; + Stmts : List_Id) return Entity_Id; -- This function generates the tree for Deep_Initialize, Deep_Adjust or - -- Deep_Finalize procedures according to the first parameter, these - -- procedures operate on the type Typ. The Stmts parameter gives the body - -- of the procedure. + -- Deep_Finalize procedures according to the first parameter. These + -- procedures operate on the type Typ. The Stmts parameter gives the + -- body of the procedure. function Make_Deep_Array_Body (Prim : Final_Primitives; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 427b430..694cf90 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -145,7 +145,7 @@ package body Exp_Ch9 is function Build_Corresponding_Record (N : Node_Id; - Ctyp : Node_Id; + Ctyp : Entity_Id; Loc : Source_Ptr) return Node_Id; -- Common to tasks and protected types. Copy discriminant specifications, -- build record declaration. N is the type declaration, Ctyp is the @@ -1583,9 +1583,9 @@ package body Exp_Ch9 is -------------------------------- function Build_Corresponding_Record - (N : Node_Id; - Ctyp : Entity_Id; - Loc : Source_Ptr) return Node_Id + (N : Node_Id; + Ctyp : Entity_Id; + Loc : Source_Ptr) return Node_Id is Rec_Ent : constant Entity_Id := Make_Defining_Identifier @@ -13796,14 +13796,15 @@ package body Exp_Ch9 is Comp : Node_Id; Comp_Id : Entity_Id; Decl_Id : Entity_Id; + Nam : Name_Id; begin Comp := First (Private_Declarations (Def)); while Present (Comp) loop if Nkind (Comp) = N_Component_Declaration then Comp_Id := Defining_Identifier (Comp); - Decl_Id := - Make_Defining_Identifier (Loc, Chars (Comp_Id)); + Nam := Chars (Comp_Id); + Decl_Id := Make_Defining_Identifier (Sloc (Comp_Id), Nam); -- Minimal decoration @@ -13818,6 +13819,14 @@ package body Exp_Ch9 is Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id)); + -- Copy the Comes_From_Source flag of the component, as + -- the renaming may be the only entity directly seen by + -- the user in the context, but do not warn for it. + + Set_Comes_From_Source + (Decl_Id, Comes_From_Source (Comp_Id)); + Set_Warnings_Off (Decl_Id); + -- Generate: -- comp_name : comp_typ renames _object.comp_name; @@ -13828,10 +13837,8 @@ package body Exp_Ch9 is New_Occurrence_Of (Etype (Comp_Id), Loc), Name => Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Obj_Ent, Loc), - Selector_Name => - Make_Identifier (Loc, Chars (Comp_Id)))); + Prefix => New_Occurrence_Of (Obj_Ent, Loc), + Selector_Name => Make_Identifier (Loc, Nam))); Add (Decl); end if; @@ -14867,7 +14874,7 @@ package body Exp_Ch9 is Actuals : List_Id; Formals : List_Id; Decls : List_Id; - Stmts : List_Id) return Node_Id + Stmts : List_Id) return Entity_Id is Actual : Entity_Id; Expr : Node_Id := Empty; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index a375169..96d78cc 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -409,7 +409,9 @@ package body Exp_Dbug is when N_Expanded_Name | N_Identifier => - if not Present (Renamed_Object (Entity (Ren))) then + if No (Entity (Ren)) + or else not Present (Renamed_Object (Entity (Ren))) + then exit; end if; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index bac6492..6ade54b 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -63,7 +63,6 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; -with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -348,7 +347,7 @@ package body Exp_Disp is -- Build_Static_Dispatch_Tables -- ---------------------------------- - procedure Build_Static_Dispatch_Tables (N : Entity_Id) is + procedure Build_Static_Dispatch_Tables (N : Node_Id) is Target_List : List_Id; procedure Build_Dispatch_Tables (List : List_Id); @@ -697,233 +696,11 @@ package body Exp_Disp is Eq_Prim_Op : Entity_Id := Empty; Controlling_Tag : Node_Id; - procedure Build_Class_Wide_Check (E : Entity_Id); - -- If the denoted subprogram has a class-wide precondition, generate a - -- check using that precondition before the dispatching call, because - -- this is the only class-wide precondition that applies to the call; - -- otherwise climb to the ancestors searching for the enclosing - -- overridden primitive of E that has a class-wide precondition (and - -- use it to generate the check). - function New_Value (From : Node_Id) return Node_Id; -- From is the original Expression. New_Value is equivalent to a call -- to Duplicate_Subexpr with an explicit dereference when From is an -- access parameter. - ---------------------------- - -- Build_Class_Wide_Check -- - ---------------------------- - - procedure Build_Class_Wide_Check (E : Entity_Id) is - Subp : Entity_Id := E; - - function Has_Class_Wide_Precondition - (Subp : Entity_Id) return Boolean; - -- Evaluates if the dispatching subprogram Subp has a class-wide - -- precondition. - - function Replace_Formals (N : Node_Id) return Traverse_Result; - -- Replace occurrences of the formals of the subprogram by the - -- corresponding actuals in the call, given that this check is - -- performed outside of the body of the subprogram. - - -- If the dispatching call appears in the same scope as the - -- declaration of the dispatching subprogram (for example in - -- the expression of a local expression function), the spec - -- has not been analyzed yet, in which case we use the Chars - -- field to recognize intended occurrences of the formals. - - --------------------------------- - -- Has_Class_Wide_Precondition -- - --------------------------------- - - function Has_Class_Wide_Precondition - (Subp : Entity_Id) return Boolean - is - Prec : Node_Id := Empty; - - begin - if Present (Contract (Subp)) - and then Present (Pre_Post_Conditions (Contract (Subp))) - then - Prec := Pre_Post_Conditions (Contract (Subp)); - - while Present (Prec) loop - exit when Pragma_Name (Prec) = Name_Precondition - and then Class_Present (Prec); - Prec := Next_Pragma (Prec); - end loop; - end if; - - return Present (Prec) - and then not Is_Ignored (Prec); - end Has_Class_Wide_Precondition; - - --------------------- - -- Replace_Formals -- - --------------------- - - function Replace_Formals (N : Node_Id) return Traverse_Result is - A : Node_Id; - F : Entity_Id; - begin - if Is_Entity_Name (N) then - F := First_Formal (Subp); - A := First_Actual (Call_Node); - - if Present (Entity (N)) and then Is_Formal (Entity (N)) then - while Present (F) loop - if F = Entity (N) then - if not Is_Controlling_Actual (N) then - Rewrite (N, New_Copy_Tree (A)); - - -- If the formal is class-wide, and thus not a - -- controlling argument, preserve its type because - -- it may appear in a nested call with a class-wide - -- parameter. - - if Is_Class_Wide_Type (Etype (F)) then - Set_Etype (N, Etype (F)); - - -- Conversely, if this is a controlling argument - -- (in a dispatching call in the condition) that - -- is a dereference, the source is an access-to- - -- -class-wide type, so preserve the dispatching - -- nature of the call in the rewritten condition. - - elsif Nkind (Parent (N)) = N_Explicit_Dereference - and then Is_Controlling_Actual (Parent (N)) - then - Set_Controlling_Argument (Parent (Parent (N)), - Parent (N)); - end if; - - -- Ensure that the type of the controlling actual - -- matches the type of the controlling formal of the - -- parent primitive Subp defining the class-wide - -- precondition. - - elsif Is_Class_Wide_Type (Etype (A)) then - Rewrite (N, - Convert_To - (Class_Wide_Type (Etype (F)), - New_Copy_Tree (A))); - - else - Rewrite (N, - Convert_To - (Etype (F), - New_Copy_Tree (A))); - end if; - - exit; - end if; - - Next_Formal (F); - Next_Actual (A); - end loop; - - -- If the node is not analyzed, recognize occurrences of a - -- formal by name, as would be done when resolving the aspect - -- expression in the context of the subprogram. - - elsif not Analyzed (N) - and then Nkind (N) = N_Identifier - and then No (Entity (N)) - then - while Present (F) loop - if Chars (N) = Chars (F) then - Rewrite (N, New_Copy_Tree (A)); - return Skip; - end if; - - Next_Formal (F); - Next_Actual (A); - end loop; - end if; - end if; - - return OK; - end Replace_Formals; - - procedure Update is new Traverse_Proc (Replace_Formals); - - -- Local variables - - Str_Loc : constant String := Build_Location_String (Loc); - - A : Node_Id; - Cond : Node_Id; - Msg : Node_Id; - Prec : Node_Id; - - -- Start of processing for Build_Class_Wide_Check - - begin - -- Climb searching for the enclosing class-wide precondition - - while not Has_Class_Wide_Precondition (Subp) - and then Present (Overridden_Operation (Subp)) - loop - Subp := Overridden_Operation (Subp); - end loop; - - -- Locate class-wide precondition, if any - - if Present (Contract (Subp)) - and then Present (Pre_Post_Conditions (Contract (Subp))) - then - Prec := Pre_Post_Conditions (Contract (Subp)); - - while Present (Prec) loop - exit when Pragma_Name (Prec) = Name_Precondition - and then Class_Present (Prec); - Prec := Next_Pragma (Prec); - end loop; - - if No (Prec) or else Is_Ignored (Prec) then - return; - end if; - - -- Ensure that the evaluation of the actuals will not produce side - -- effects (since the check will use a copy of the actuals). - - A := First_Actual (Call_Node); - while Present (A) loop - Remove_Side_Effects (A); - Next_Actual (A); - end loop; - - -- The expression for the precondition is analyzed within the - -- generated pragma. The message text is the last parameter of - -- the generated pragma, indicating source of precondition. - - Cond := - New_Copy_Tree - (Expression (First (Pragma_Argument_Associations (Prec)))); - Update (Cond); - - -- Build message indicating the failed precondition and the - -- dispatching call that caused it. - - Msg := Expression (Last (Pragma_Argument_Associations (Prec))); - Name_Len := 0; - Append (Global_Name_Buffer, Strval (Msg)); - Append (Global_Name_Buffer, " in dispatching call at "); - Append (Global_Name_Buffer, Str_Loc); - Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); - - Insert_Action (Call_Node, - Make_If_Statement (Loc, - Condition => Make_Op_Not (Loc, Cond), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), - Parameter_Associations => New_List (Msg))))); - end if; - end Build_Class_Wide_Check; - --------------- -- New_Value -- --------------- @@ -984,8 +761,6 @@ package body Exp_Disp is Subp := Alias (Subp); end if; - Build_Class_Wide_Check (Subp); - -- Definition of the class-wide type and the tagged type -- If the controlling argument is itself a tag rather than a tagged @@ -1016,6 +791,10 @@ package body Exp_Disp is Typ := Find_Specific_Type (CW_Typ); + -- The tagged type of a dispatching call must be frozen at this stage + + pragma Assert (Is_Frozen (Typ)); + if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; @@ -5924,6 +5703,11 @@ package body Exp_Disp is Set_Is_True_Constant (TSD, Building_Static_DT (Typ)); + -- The debugging information for type Ada.Tags.Type_Specific_Data is + -- needed by the debugger in order to display values of tagged types. + + Set_Needs_Debug_Info (TSD, Needs_Debug_Info (Typ)); + -- Initialize or declare the dispatch table object if not Has_DT (Typ) then diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 45de0fb..86cb702 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1151,7 +1151,7 @@ package body Exp_Intr is else Set_Procedure_To_Call - (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate)); + (Free_Nod, Find_Storage_Op (Etype (Pool), Name_Deallocate)); end if; end if; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 43ecdcd..27b4e7d 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -752,10 +752,10 @@ package body Exp_Prag is -- 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; + (Decl_Id : Entity_Id; + Init_Val : Node_Id; + Typ : Node_Id; + Default_Val : Node_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. @@ -983,7 +983,7 @@ package body Exp_Prag is function Build_Simple_Declaration_With_Default (Decl_Id : Entity_Id; Init_Val : Node_Id; - Typ : Entity_Id; + Typ : Node_Id; Default_Val : Node_Id) return Node_Id is Value : Node_Id := Init_Val; @@ -1525,9 +1525,7 @@ package body Exp_Prag is begin -- Attribute 'Old - if Nkind (N) = N_Attribute_Reference - and then Attribute_Name (N) = Name_Old - then + if Is_Attribute_Old (N) then Pref := Prefix (N); Indirect := Indirect_Temp_Needed (Etype (Pref)); @@ -2862,7 +2860,7 @@ package body Exp_Prag is procedure Expand_Pragma_Subprogram_Variant (Prag : Node_Id; - Subp_Id : Node_Id; + Subp_Id : Entity_Id; Body_Decls : List_Id) is Curr_Decls : List_Id; diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index 45db487..216065f5 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -86,7 +86,7 @@ package body Exp_Smem is function Build_Shared_Var_Proc_Call (Loc : Source_Ptr; - E : Node_Id; + E : Entity_Id; N : Name_Id) return Node_Id; -- Build a call to support procedure N for shared object E (provided by the -- instance of System.Shared_Storage.Shared_Var_Procs associated to E). diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ad5a6fa..cb18096 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1270,11 +1270,10 @@ package body Exp_Util is --------------------------------- procedure Build_Class_Wide_Expression - (Prag : Node_Id; - Subp : Entity_Id; - Par_Subp : Entity_Id; - Adjust_Sloc : Boolean; - Needs_Wrapper : out Boolean) + (Pragma_Or_Expr : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id; + Adjust_Sloc : Boolean) is function Replace_Entity (N : Node_Id) return Traverse_Result; -- Replace reference to formal of inherited operation or to primitive @@ -1294,7 +1293,7 @@ package body Exp_Util is Adjust_Inherited_Pragma_Sloc (N); end if; - if Nkind (N) = N_Identifier + if Nkind (N) in N_Identifier | N_Operator_Symbol and then Present (Entity (N)) and then (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N))) @@ -1319,84 +1318,6 @@ package body Exp_Util is if Present (New_E) then Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); - - -- AI12-0166: a precondition for a protected operation - -- cannot include an internal call to a protected function - -- of the type. In the case of an inherited condition for an - -- overriding operation, both the operation and the function - -- are given by primitive wrappers. - -- Move this check to sem??? - - if Ekind (New_E) = E_Function - and then Is_Primitive_Wrapper (New_E) - and then Is_Primitive_Wrapper (Subp) - and then Scope (Subp) = Scope (New_E) - and then Chars (Pragma_Identifier (Prag)) = Name_Precondition - then - Error_Msg_Node_2 := Wrapped_Entity (Subp); - Error_Msg_NE - ("internal call to& cannot appear in inherited " - & "precondition of protected operation&", - N, Wrapped_Entity (New_E)); - end if; - - -- If the entity is an overridden primitive and we are not - -- in GNATprove mode, we must build a wrapper for the current - -- inherited operation. If the reference is the prefix of an - -- attribute such as 'Result (or others ???) there is no need - -- for a wrapper: the condition is just rewritten in terms of - -- the inherited subprogram. - - if Is_Subprogram (New_E) - and then Nkind (Parent (N)) /= N_Attribute_Reference - and then not GNATprove_Mode - then - Needs_Wrapper := True; - end if; - end if; - - -- Check that there are no calls left to abstract operations if - -- the current subprogram is not abstract. - -- Move this check to sem??? - - if Nkind (Parent (N)) = N_Function_Call - and then N = Name (Parent (N)) - then - if not Is_Abstract_Subprogram (Subp) - and then Is_Abstract_Subprogram (Entity (N)) - then - Error_Msg_Sloc := Sloc (Current_Scope); - Error_Msg_Node_2 := Subp; - if Comes_From_Source (Subp) then - Error_Msg_NE - ("cannot call abstract subprogram & in inherited " - & "condition for&#", Subp, Entity (N)); - else - Error_Msg_NE - ("cannot call abstract subprogram & in inherited " - & "condition for inherited&#", Subp, Entity (N)); - end if; - - -- In SPARK mode, reject an inherited condition for an - -- inherited operation if it contains a call to an overriding - -- operation, because this implies that the pre/postconditions - -- of the inherited operation have changed silently. - - elsif SPARK_Mode = On - and then Warn_On_Suspicious_Contract - and then Present (Alias (Subp)) - and then Present (New_E) - and then Comes_From_Source (New_E) - then - Error_Msg_N - ("cannot modify inherited condition (SPARK RM 6.1.1(1))", - Parent (Subp)); - Error_Msg_Sloc := Sloc (New_E); - Error_Msg_Node_2 := Subp; - Error_Msg_NE - ("\overriding of&# forces overriding of&", - Parent (Subp), New_E); - end if; end if; -- Update type of function call node, which should be the same as @@ -1422,26 +1343,17 @@ package body Exp_Util is -- Local variables - Par_Formal : Entity_Id; - Subp_Formal : Entity_Id; + Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Subp); + Subp_Typ : constant Entity_Id := Find_Dispatching_Type (Subp); -- Start of processing for Build_Class_Wide_Expression begin - Needs_Wrapper := False; + pragma Assert (Par_Typ /= Subp_Typ); - -- Add mapping from old formals to new formals - - Par_Formal := First_Formal (Par_Subp); - Subp_Formal := First_Formal (Subp); - - while Present (Par_Formal) and then Present (Subp_Formal) loop - Type_Map.Set (Par_Formal, Subp_Formal); - Next_Formal (Par_Formal); - Next_Formal (Subp_Formal); - end loop; - - Replace_Condition_Entities (Prag); + Update_Primitives_Mapping (Par_Subp, Subp); + Map_Formals (Par_Subp, Subp); + Replace_Condition_Entities (Pragma_Or_Expr); end Build_Class_Wide_Expression; -------------------- @@ -1895,7 +1807,33 @@ package body Exp_Util is Priv_Typ : Entity_Id; -- The partial view of Par_Typ + Op_Node : Elmt_Id; + Par_Prim : Entity_Id; + Prim : Entity_Id; + begin + -- Map the overridden primitive to the overriding one; required by + -- Replace_References (called by Add_Inherited_DICs) to handle calls + -- to parent primitives. + + Op_Node := First_Elmt (Primitive_Operations (T)); + while Present (Op_Node) loop + Prim := Node (Op_Node); + + if Present (Overridden_Operation (Prim)) + and then Comes_From_Source (Prim) + then + Par_Prim := Overridden_Operation (Prim); + + -- Create a mapping of the form: + -- parent type primitive -> derived type primitive + + Type_Map.Set (Par_Prim, Prim); + end if; + + Next_Elmt (Op_Node); + end loop; + -- Climb the parent type chain Curr_Typ := T; @@ -2097,14 +2035,11 @@ package body Exp_Util is Stmts => Stmts); end if; - -- Otherwise the "full" DIC procedure verifies the DICs of the full - -- view, well as DICs inherited from parent types. In addition, it - -- indirectly verifies the DICs of the partial view by calling the - -- "partial" DIC procedure. + -- Otherwise, the "full" DIC procedure verifies the DICs inherited from + -- parent types, as well as indirectly verifying the DICs of the partial + -- view by calling the "partial" DIC procedure. else - pragma Assert (Present (Full_Typ)); - -- Check the DIC of the partial view by calling the "partial" DIC -- procedure, unless the partial DIC body is empty. Generate: @@ -2118,44 +2053,6 @@ package body Exp_Util is New_Occurrence_Of (Obj_Id, Loc)))); end if; - -- Derived subtypes do not have a partial view - - if Present (Priv_Typ) then - - -- The processing of the "full" DIC procedure intentionally - -- skips the partial view because a) this may result in changes of - -- visibility and b) lead to duplicate checks. However, when the - -- full view is the underlying full view of an untagged derived - -- type whose parent type is private, partial DICs appear on - -- the rep item chain of the partial view only. - - -- package Pack_1 is - -- type Root ... is private; - -- private - -- <full view of Root> - -- end Pack_1; - - -- with Pack_1; - -- package Pack_2 is - -- type Child is new Pack_1.Root with Type_DIC => ...; - -- <underlying full view of Child> - -- end Pack_2; - - -- As a result, the processing of the full view must also consider - -- all DICs of the partial view. - - if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then - null; - - -- Otherwise the DICs of the partial view are ignored - - else - -- Ignore the DICs of the partial view by eliminating the view - - Priv_Typ := Empty; - end if; - end if; - -- Process inherited Default_Initial_Conditions for all parent types Add_Parent_DICs (Work_Typ, Obj_Id, Stmts); @@ -4914,7 +4811,7 @@ package body Exp_Util is -- Convert_To_Actual_Subtype -- ------------------------------- - procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is + procedure Convert_To_Actual_Subtype (Exp : Node_Id) is Act_ST : Entity_Id; begin @@ -6359,6 +6256,32 @@ package body Exp_Util is raise Program_Error; end Find_Protection_Type; + function Find_Storage_Op + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + use Sem_Util.Storage_Model_Support; + + begin + if Has_Storage_Model_Type_Aspect (Typ) then + declare + SMT_Op : constant Entity_Id := + Get_Storage_Model_Type_Entity (Typ, Nam); + begin + if not Present (SMT_Op) then + raise Program_Error; + else + return SMT_Op; + end if; + end; + + -- Otherwise we assume that Typ is a descendant of Root_Storage_Pool + + else + return Find_Prim_Op (Typ, Nam); + end if; + end Find_Storage_Op; + ----------------------- -- Find_Hook_Context -- ----------------------- @@ -7048,7 +6971,7 @@ package body Exp_Util is -- Get_Index_Subtype -- ----------------------- - function Get_Index_Subtype (N : Node_Id) return Node_Id is + function Get_Index_Subtype (N : Node_Id) return Entity_Id is P_Type : Entity_Id := Etype (Prefix (N)); Indx : Node_Id; J : Int; @@ -7073,6 +6996,15 @@ package body Exp_Util is return Etype (Indx); end Get_Index_Subtype; + ----------------------- + -- Get_Mapped_Entity -- + ----------------------- + + function Get_Mapped_Entity (E : Entity_Id) return Entity_Id is + begin + return Type_Map.Get (E); + end Get_Mapped_Entity; + --------------------- -- Get_Stream_Size -- --------------------- @@ -10350,6 +10282,36 @@ package body Exp_Util is end if; end Make_Variant_Comparison; + ----------------- + -- Map_Formals -- + ----------------- + + procedure Map_Formals + (Parent_Subp : Entity_Id; + Derived_Subp : Entity_Id; + Force_Update : Boolean := False) + is + Par_Formal : Entity_Id := First_Formal (Parent_Subp); + Subp_Formal : Entity_Id := First_Formal (Derived_Subp); + + begin + if Force_Update then + Type_Map.Set (Parent_Subp, Derived_Subp); + end if; + + -- At this stage either we are under regular processing and the caller + -- has previously ensured that these primitives are already mapped (by + -- means of calling previously to Update_Primitives_Mapping), or we are + -- processing a late-overriding primitive and Force_Update updated above + -- the mapping of these primitives. + + while Present (Par_Formal) and then Present (Subp_Formal) loop + Type_Map.Set (Par_Formal, Subp_Formal); + Next_Formal (Par_Formal); + Next_Formal (Subp_Formal); + end loop; + end Map_Formals; + --------------- -- Map_Types -- --------------- @@ -10645,7 +10607,7 @@ package body Exp_Util is end if; -- Otherwise the constraint denotes a reference to some name - -- which results in a Girder discriminant: + -- which results in a Stored discriminant: -- vvvv -- Name : ...; @@ -10666,7 +10628,7 @@ package body Exp_Util is return Find_Constraint_Value (Entity (Constr)); -- Otherwise the current constraint is an expression which yields - -- a Girder discriminant: + -- a Stored discriminant: -- type Typ (D1 : ...; DN : ...) is -- new Anc (Discr => <expression>) with ... @@ -10741,7 +10703,7 @@ package body Exp_Util is -- that D_2 constrains D_1, therefore if the algorithm finds the -- value of D_2, then this would also be the value for D_1. - -- 2.2) The constraint is a name (aka Girder): + -- 2.2) The constraint is a name (aka Stored): -- Name : ... -- type Ancestor_1 (D_1 : ...) is tagged ... @@ -10750,7 +10712,7 @@ package body Exp_Util is -- In this case the name is the final value of D_1 because the -- discriminant cannot be further constrained. - -- 2.3) The constraint is an expression (aka Girder): + -- 2.3) The constraint is an expression (aka Stored): -- type Ancestor_1 (D_1 : ...) is tagged ... -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ... @@ -10861,7 +10823,7 @@ package body Exp_Util is -- they relate to the primitives of the parent type. If there is a -- meaningful relation, create a mapping of the form: - -- parent type primitive -> perived type primitive + -- parent type primitive -> derived type primitive if Present (Direct_Primitive_Operations (Deriv_Typ)) then Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ)); @@ -11801,10 +11763,15 @@ package body Exp_Util is -- case and it is better not to make an additional one for the attribute -- itself, because the return type of many of them is universal integer, -- which is a very large type for a temporary. + -- The prefix of an attribute reference Reduce may be syntactically an + -- aggregate, but will be expanded into a loop, so no need to remove + -- side-effects. if Nkind (Exp) = N_Attribute_Reference and then Side_Effect_Free_Attribute (Attribute_Name (Exp)) and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref) + and then (Attribute_Name (Exp) /= Name_Reduce + or else Nkind (Prefix (Exp)) /= N_Aggregate) and then not Is_Name_Reference (Prefix (Exp)) then Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref); @@ -14123,10 +14090,12 @@ package body Exp_Util is (Inher_Id : Entity_Id; Subp_Id : Entity_Id) is + Parent_Type : constant Entity_Id := Find_Dispatching_Type (Inher_Id); + Derived_Type : constant Entity_Id := Find_Dispatching_Type (Subp_Id); + begin - Map_Types - (Parent_Type => Find_Dispatching_Type (Inher_Id), - Derived_Type => Find_Dispatching_Type (Subp_Id)); + pragma Assert (Parent_Type /= Derived_Type); + Map_Types (Parent_Type, Derived_Type); end Update_Primitives_Mapping; ---------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 56ff61f..2b61132 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -270,28 +270,16 @@ package Exp_Util is -- not install a call to Abort_Defer. procedure Build_Class_Wide_Expression - (Prag : Node_Id; - Subp : Entity_Id; - Par_Subp : Entity_Id; - Adjust_Sloc : Boolean; - Needs_Wrapper : out Boolean); - -- Build the expression for an inherited class-wide condition. Prag is - -- the pragma constructed from the corresponding aspect of the parent - -- subprogram, and Subp is the overriding operation, and Par_Subp is - -- the overridden operation that has the condition. Adjust_Sloc is True - -- when the sloc of nodes traversed should be adjusted for the inherited - -- pragma. The routine is also called to check whether an inherited - -- operation that is not overridden but has inherited conditions needs - -- a wrapper, because the inherited condition includes calls to other - -- primitives that have been overridden. In that case the first argument - -- is the expression of the original class-wide aspect. In SPARK_Mode, such - -- operation which are just inherited but have modified pre/postconditions - -- are illegal. - -- If there are calls to overridden operations in the condition, and the - -- pragma applies to an inherited operation, a wrapper must be built for - -- it to capture the new inherited condition. The flag Needs_Wrapper is - -- set in that case so that the wrapper can be built, when the controlling - -- type is frozen. + (Pragma_Or_Expr : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id; + Adjust_Sloc : Boolean); + -- Build the expression for an inherited class-wide condition. Pragma_Or_ + -- _Expr is either the pragma constructed from the corresponding aspect of + -- the parent subprogram or the class-wide pre/postcondition built from the + -- parent, Subp is the overriding operation, and Par_Subp is the overridden + -- operation that has the condition. Adjust_Sloc is True when the sloc of + -- nodes traversed should be adjusted for the inherited pragma. function Build_DIC_Call (Loc : Source_Ptr; @@ -612,7 +600,7 @@ package Exp_Util is function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id; -- Find the first primitive operation of a tagged type T with name Name. -- This function allows the use of a primitive operation which is not - -- directly visible. If T is a class wide type, then the reference is to an + -- directly visible. If T is a class-wide type, then the reference is to an -- operation of the corresponding root type. It is an error if no primitive -- operation with the given name is found. @@ -640,6 +628,16 @@ package Exp_Util is -- Given a protected type or its corresponding record, find the type of -- field _object. + function Find_Storage_Op + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Given type Typ that's either a descendant of Root_Storage_Pool or else + -- specifies aspect Storage_Model_Type, returns the Entity_Id of the + -- subprogram associated with Nam, which must either be a primitive op of + -- the type in the case of a storage pool, or the operation corresponding + -- to Nam as specified in the aspect Storage_Model_Type. It is an error if + -- no operation corresponding to the given name is found. + function Find_Hook_Context (N : Node_Id) return Node_Id; -- Determine a suitable node on which to attach actions related to N that -- need to be elaborated unconditionally. In general this is the topmost @@ -739,6 +737,10 @@ package Exp_Util is -- Used for First, Last, and Length, when the prefix is an array type. -- Obtains the corresponding index subtype. + function Get_Mapped_Entity (E : Entity_Id) return Entity_Id; + -- Return the mapped entity of E; used to check inherited class-wide + -- pre/postconditions. + function Get_Stream_Size (E : Entity_Id) return Uint; -- Return the stream size value of the subtype E @@ -918,6 +920,15 @@ package Exp_Util is -- Subprogram_Variant. Generate a comparison between Curr_Val and Old_Val -- depending on the variant mode (Increases / Decreases). + procedure Map_Formals + (Parent_Subp : Entity_Id; + Derived_Subp : Entity_Id; + Force_Update : Boolean := False); + -- Establish the mapping from the formals of Parent_Subp to the formals + -- of Derived_Subp; if Force_Update is True then mapping of Parent_Subp to + -- Derived_Subp is also updated; used to update mapping of late-overriding + -- primitives of a tagged type. + 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. @@ -1205,5 +1216,6 @@ package Exp_Util is private pragma Inline (Duplicate_Subexpr); pragma Inline (Force_Evaluation); + pragma Inline (Get_Mapped_Entity); pragma Inline (Is_Library_Level_Tagged_Type); end Exp_Util; diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index 488e811..957f40b 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -61,10 +61,12 @@ extern void Compiler_Abort (String_Pointer, String_Pointer, Boolean) ATTRIBUTE_N #define Debug_Flag_Dot_KK debug__debug_flag_dot_kk #define Debug_Flag_Dot_R debug__debug_flag_dot_r +#define Debug_Flag_Dot_8 debug__debug_flag_dot_8 #define Debug_Flag_NN debug__debug_flag_nn extern Boolean Debug_Flag_Dot_KK; extern Boolean Debug_Flag_Dot_R; +extern Boolean Debug_Flag_Dot_8; extern Boolean Debug_Flag_NN; /* einfo: */ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 15ce832..5f81d9e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -35,6 +35,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Ch3; use Exp_Ch3; with Exp_Ch7; use Exp_Ch7; +with Exp_Disp; use Exp_Disp; with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; @@ -56,6 +57,7 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Prag; use Sem_Prag; @@ -132,11 +134,6 @@ package body Freeze is -- Attribute references to outer types are freeze points for those types; -- this routine generates the required freeze nodes for them. - procedure Check_Inherited_Conditions (R : Entity_Id); - -- For a tagged derived type, create wrappers for inherited operations - -- that have a class-wide condition, so it can be properly rewritten if - -- it involves calls to other overriding primitives. - procedure Check_Strict_Alignment (E : Entity_Id); -- E is a base type. If E is tagged or has a component that is aliased -- or tagged or contains something this is aliased or tagged, set @@ -160,7 +157,7 @@ package body Freeze is procedure Freeze_Enumeration_Type (Typ : Entity_Id); -- Freeze enumeration type. The Esize field is set as processing -- proceeds (i.e. set by default when the type is declared and then - -- adjusted by rep clauses. What this procedure does is to make sure + -- adjusted by rep clauses). What this procedure does is to make sure -- that if a foreign convention is specified, and no specific size -- is given, then the size must be at least Integer'Size. @@ -284,11 +281,11 @@ package body Freeze is -- Full_View or Corresponding_Record_Type. procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id); - -- Expr is the expression for an address clause for entity Nam whose type - -- is Typ. If Typ has a default initialization, and there is no explicit - -- initialization in the source declaration, check whether the address - -- clause might cause overlaying of an entity, and emit a warning on the - -- side effect that the initialization will cause. + -- Expr is the expression for an address clause for the entity denoted by + -- Nam whose type is Typ. If Typ has a default initialization, and there is + -- no explicit initialization in the source declaration, check whether the + -- address clause might cause overlaying of an entity, and emit a warning + -- on the side effect that the initialization will cause. ------------------------------- -- Adjust_Esize_For_Alignment -- @@ -636,13 +633,26 @@ package body Freeze is Next (Param_Spec); end loop; - Body_Node := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call_Node))); + -- In GNATprove, prefer to generate an expression function whenever + -- possible, to benefit from the more precise analysis in that case + -- (as if an implicit postcondition had been generated). + + if GNATprove_Mode + and then Nkind (Call_Node) = N_Simple_Return_Statement + then + Body_Node := + Make_Expression_Function (Loc, + Specification => Spec, + Expression => Expression (Call_Node)); + else + Body_Node := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call_Node))); + end if; if Nkind (Decl) /= N_Subprogram_Declaration then Rewrite (N, @@ -1352,9 +1362,15 @@ package body Freeze is elsif Is_Record_Type (Encl_Base) and then not Comp_Byte_Aligned then - Error_Msg_N - ("type of non-byte-aligned component must have same scalar " - & "storage order as enclosing composite", Err_Node); + if Present (Component_Clause (Comp)) then + Error_Msg_N + ("type of non-byte-aligned component must have same scalar" + & " storage order as enclosing record", Err_Node); + else + Error_Msg_N + ("type of packed component must have same scalar" + & " storage order as enclosing record", Err_Node); + end if; -- Warn if specified only for the outer composite @@ -1464,90 +1480,322 @@ package body Freeze is -- Check_Inherited_Conditions -- -------------------------------- - procedure Check_Inherited_Conditions (R : Entity_Id) is - Prim_Ops : constant Elist_Id := Primitive_Operations (R); - Decls : List_Id; - Needs_Wrapper : Boolean; - Op_Node : Elmt_Id; - Par_Prim : Entity_Id; - Prim : Entity_Id; - - procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id); + procedure Check_Inherited_Conditions + (R : Entity_Id; + Late_Overriding : Boolean := False) + is + Prim_Ops : constant Elist_Id := Primitive_Operations (R); + Decls : List_Id; + Op_Node : Elmt_Id; + Par_Prim : Entity_Id; + Prim : Entity_Id; + Wrapper_Needed : Boolean; + + function Build_DTW_Body + (Loc : Source_Ptr; + DTW_Spec : Node_Id; + DTW_Decls : List_Id; + Par_Prim : Entity_Id; + Wrapped_Subp : Entity_Id) return Node_Id; + -- Build the body of the dispatch table wrapper containing the given + -- spec and declarations; the call to the wrapped subprogram includes + -- the proper type conversion. + + function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id; + -- Build the spec of the dispatch table wrapper + + procedure Build_Inherited_Condition_Pragmas + (Subp : Entity_Id; + Wrapper_Needed : out Boolean); -- Build corresponding pragmas for an operation whose ancestor has - -- class-wide pre/postconditions. If the operation is inherited, the - -- pragmas force the creation of a wrapper for the inherited operation. - -- If the ancestor is being overridden, the pragmas are constructed only - -- to verify their legality, in case they contain calls to other - -- primitives that may have been overridden. + -- class-wide pre/postconditions. If the operation is inherited then + -- Wrapper_Needed is returned True to force the creation of a wrapper + -- for the inherited operation. If the ancestor is being overridden, + -- the pragmas are constructed only to verify their legality, in case + -- they contain calls to other primitives that may have been overridden. + + function Needs_Wrapper + (Class_Cond : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id) return Boolean; + -- Checks whether the dispatch-table wrapper (DTW) for Subp must be + -- built to evaluate the given class-wide condition. + + -------------------- + -- Build_DTW_Body -- + -------------------- + + function Build_DTW_Body + (Loc : Source_Ptr; + DTW_Spec : Node_Id; + DTW_Decls : List_Id; + Par_Prim : Entity_Id; + Wrapped_Subp : Entity_Id) return Node_Id + is + Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Prim); + Actuals : constant List_Id := Empty_List; + Call : Node_Id; + Formal : Entity_Id := First_Formal (Par_Prim); + New_F_Spec : Entity_Id := First (Parameter_Specifications (DTW_Spec)); + New_Formal : Entity_Id; + + begin + -- Build parameter association for call to wrapped subprogram + + while Present (Formal) loop + New_Formal := Defining_Identifier (New_F_Spec); + + -- If the controlling argument is inherited, add conversion to + -- parent type for the call. + + if Etype (Formal) = Par_Typ + and then Is_Controlling_Formal (Formal) + then + Append_To (Actuals, + Make_Type_Conversion (Loc, + New_Occurrence_Of (Par_Typ, Loc), + New_Occurrence_Of (New_Formal, Loc))); + else + Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); + end if; + + Next_Formal (Formal); + Next (New_F_Spec); + end loop; + + if Ekind (Wrapped_Subp) = E_Procedure then + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Wrapped_Subp, Loc), + Parameter_Associations => Actuals); + else + Call := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Wrapped_Subp, Loc), + Parameter_Associations => Actuals)); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Copy_Subprogram_Spec (DTW_Spec), + Declarations => DTW_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call), + End_Label => Make_Identifier (Loc, + Chars (Defining_Entity (DTW_Spec))))); + end Build_DTW_Body; + + -------------------- + -- Build_DTW_Spec -- + -------------------- + + function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id is + DTW_Id : Entity_Id; + DTW_Spec : Node_Id; + + begin + DTW_Spec := Build_Overriding_Spec (Par_Prim, R); + DTW_Id := Defining_Entity (DTW_Spec); + + -- Add minimal decoration of fields + + Mutate_Ekind (DTW_Id, Ekind (Par_Prim)); + Set_LSP_Subprogram (DTW_Id, Par_Prim); + Set_Is_Dispatch_Table_Wrapper (DTW_Id); + Set_Is_Wrapper (DTW_Id); + + -- The DTW wrapper is never a null procedure + + if Nkind (DTW_Spec) = N_Procedure_Specification then + Set_Null_Present (DTW_Spec, False); + end if; + + return DTW_Spec; + end Build_DTW_Spec; --------------------------------------- -- Build_Inherited_Condition_Pragmas -- --------------------------------------- - procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id) is - A_Post : Node_Id; - A_Pre : Node_Id; - New_Prag : Node_Id; + procedure Build_Inherited_Condition_Pragmas + (Subp : Entity_Id; + Wrapper_Needed : out Boolean) + is + Class_Pre : constant Node_Id := + Class_Preconditions (Ultimate_Alias (Subp)); + Class_Post : Node_Id := Class_Postconditions (Par_Prim); + A_Post : Node_Id; + New_Prag : Node_Id; begin - A_Pre := Get_Class_Wide_Pragma (Par_Prim, Pragma_Precondition); + Wrapper_Needed := False; - if Present (A_Pre) then - New_Prag := New_Copy_Tree (A_Pre); - Build_Class_Wide_Expression - (Prag => New_Prag, - Subp => Prim, - Par_Subp => Par_Prim, - Adjust_Sloc => False, - Needs_Wrapper => Needs_Wrapper); - - if Needs_Wrapper - and then not Comes_From_Source (Subp) - and then Expander_Active - then - Append (New_Prag, Decls); - end if; + if No (Class_Pre) and then No (Class_Post) then + return; end if; - A_Post := Get_Class_Wide_Pragma (Par_Prim, Pragma_Postcondition); + -- For class-wide preconditions we just evaluate whether the wrapper + -- is needed; there is no need to build the pragma since the check + -- is performed on the caller side. - if Present (A_Post) then - New_Prag := New_Copy_Tree (A_Post); + if Present (Class_Pre) + and then Needs_Wrapper (Class_Pre, Subp, Par_Prim) + then + Wrapper_Needed := True; + end if; + + -- For class-wide postconditions we evaluate whether the wrapper is + -- needed and we build the class-wide postcondition pragma to install + -- it in the wrapper. + + if Present (Class_Post) + and then Needs_Wrapper (Class_Post, Subp, Par_Prim) + then + Wrapper_Needed := True; + + -- Update the class-wide postcondition + + Class_Post := New_Copy_Tree (Class_Post); Build_Class_Wide_Expression - (Prag => New_Prag, - Subp => Prim, + (Pragma_Or_Expr => Class_Post, + Subp => Subp, Par_Subp => Par_Prim, - Adjust_Sloc => False, - Needs_Wrapper => Needs_Wrapper); + Adjust_Sloc => False); - if Needs_Wrapper - and then not Comes_From_Source (Subp) - and then Expander_Active - then - Append (New_Prag, Decls); + -- Install the updated class-wide postcondition in a copy of the + -- pragma postcondition defined for the nearest ancestor. + + A_Post := Get_Class_Wide_Pragma (Par_Prim, + Pragma_Postcondition); + + if No (A_Post) then + declare + Subps : constant Subprogram_List := + Inherited_Subprograms (Subp); + begin + for Index in Subps'Range loop + A_Post := Get_Class_Wide_Pragma (Subps (Index), + Pragma_Postcondition); + exit when Present (A_Post); + end loop; + end; end if; + + New_Prag := New_Copy_Tree (A_Post); + Rewrite + (Expression (First (Pragma_Argument_Associations (New_Prag))), + Class_Post); + Append (New_Prag, Decls); end if; end Build_Inherited_Condition_Pragmas; + ------------------- + -- Needs_Wrapper -- + ------------------- + + function Needs_Wrapper + (Class_Cond : Node_Id; + Subp : Entity_Id; + Par_Subp : Entity_Id) return Boolean + is + Result : Boolean := False; + + function Check_Entity (N : Node_Id) return Traverse_Result; + -- Check calls to overridden primitives + + -------------------- + -- Replace_Entity -- + -------------------- + + function Check_Entity (N : Node_Id) return Traverse_Result is + New_E : Entity_Id; + + begin + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then + (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N))) + and then + (Nkind (Parent (N)) /= N_Attribute_Reference + or else Attribute_Name (Parent (N)) /= Name_Class) + then + -- The check does not apply to dispatching calls within the + -- condition, but only to calls whose static tag is that of + -- the parent type. + + if Is_Subprogram (Entity (N)) + and then Nkind (Parent (N)) = N_Function_Call + and then Present (Controlling_Argument (Parent (N))) + then + return OK; + end if; + + -- Determine whether entity has a renaming + + New_E := Get_Mapped_Entity (Entity (N)); + + -- If the entity is an overridden primitive and we are not + -- in GNATprove mode, we must build a wrapper for the current + -- inherited operation. If the reference is the prefix of an + -- attribute such as 'Result (or others ???) there is no need + -- for a wrapper: the condition is just rewritten in terms of + -- the inherited subprogram. + + if Present (New_E) + and then Comes_From_Source (New_E) + and then Is_Subprogram (New_E) + and then Nkind (Parent (N)) /= N_Attribute_Reference + and then not GNATprove_Mode + then + Result := True; + return Abandon; + end if; + end if; + + return OK; + end Check_Entity; + + procedure Check_Condition_Entities is + new Traverse_Proc (Check_Entity); + + -- Start of processing for Needs_Wrapper + + begin + Update_Primitives_Mapping (Par_Subp, Subp); + + Map_Formals (Par_Subp, Subp); + Check_Condition_Entities (Class_Cond); + + return Result; + end Needs_Wrapper; + -- Start of processing for Check_Inherited_Conditions begin - Op_Node := First_Elmt (Prim_Ops); - while Present (Op_Node) loop - Prim := Node (Op_Node); + if Late_Overriding then + Op_Node := First_Elmt (Prim_Ops); + while Present (Op_Node) loop + Prim := Node (Op_Node); - -- Map the overridden primitive to the overriding one. This takes - -- care of all overridings and is done only once. + -- Map the overridden primitive to the overriding one - if Present (Overridden_Operation (Prim)) - and then Comes_From_Source (Prim) - then - Par_Prim := Overridden_Operation (Prim); - Update_Primitives_Mapping (Par_Prim, Prim); - end if; + if Present (Overridden_Operation (Prim)) + and then Comes_From_Source (Prim) + then + Par_Prim := Overridden_Operation (Prim); + Update_Primitives_Mapping (Par_Prim, Prim); - Next_Elmt (Op_Node); - end loop; + -- Force discarding previous mappings of its formals + + Map_Formals (Par_Prim, Prim, Force_Update => True); + end if; + + Next_Elmt (Op_Node); + end loop; + end if; -- Perform validity checks on the inherited conditions of overriding -- operations, for conformance with LSP, and apply SPARK-specific @@ -1583,12 +1831,6 @@ package body Freeze is if GNATprove_Mode then Collect_Inherited_Class_Wide_Conditions (Prim); - - -- Otherwise build the corresponding pragmas to check for legality - -- of the inherited condition. - - else - Build_Inherited_Condition_Pragmas (Prim); end if; end if; @@ -1602,12 +1844,17 @@ package body Freeze is Op_Node := First_Elmt (Prim_Ops); while Present (Op_Node) loop - Decls := Empty_List; - Prim := Node (Op_Node); - Needs_Wrapper := False; + Decls := Empty_List; + Prim := Node (Op_Node); + Wrapper_Needed := False; - if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then - Par_Prim := Alias (Prim); + -- Skip internal entities built for mapping interface primitives + + if not Comes_From_Source (Prim) + and then Present (Alias (Prim)) + and then No (Interface_Alias (Prim)) + then + Par_Prim := Ultimate_Alias (Prim); -- When the primitive is an LSP wrapper we climb to the parent -- primitive that has the inherited contract. @@ -1625,39 +1872,39 @@ package body Freeze is -- in the loop above. Analyze_Entry_Or_Subprogram_Contract (Par_Prim); - Build_Inherited_Condition_Pragmas (Prim); + Build_Inherited_Condition_Pragmas (Prim, Wrapper_Needed); end if; - if Needs_Wrapper + if Wrapper_Needed and then not Is_Abstract_Subprogram (Par_Prim) and then Expander_Active then - -- We need to build a new primitive that overrides the inherited - -- one, and whose inherited expression has been updated above. - -- These expressions are the arguments of pragmas that are part - -- of the declarations of the wrapper. The wrapper holds a single - -- statement that is a call to the class-wide clone, where the - -- controlling actuals are conversions to the corresponding type - -- in the parent primitive: - - -- procedure New_Prim (F1 : T1; ...); - -- procedure New_Prim (F1 : T1; ...) is - -- pragma Check (Precondition, Expr); - -- begin - -- Par_Prim_Clone (Par_Type (F1), ...); - -- end; - - -- If the primitive is a function the statement is a return - -- statement with a call. + -- Build the dispatch-table wrapper (DTW). The support for + -- AI12-0195 relies on two kind of wrappers: one for indirect + -- calls (also used for AI12-0220), and one for putting in the + -- dispatch table: + -- + -- 1) "indirect-call wrapper" (ICW) is needed anytime there are + -- class-wide preconditions. Prim'Access will point directly + -- at the ICW if any, or at the "pristine" body if Prim has + -- no class-wide preconditions. + -- + -- 2) "dispatch-table wrapper" (DTW) is needed anytime the class + -- wide preconditions *or* the class-wide postconditions are + -- affected by overriding. + -- + -- The DTW holds a single statement that is a single call where + -- the controlling actuals are conversions to the corresponding + -- type in the parent primitive. If the primitive is a function + -- the statement is a return statement with a call. declare Alias_Id : constant Entity_Id := Ultimate_Alias (Prim); Loc : constant Source_Ptr := Sloc (R); - Par_R : constant Node_Id := Parent (R); - New_Body : Node_Id; - New_Decl : Node_Id; - New_Id : Entity_Id; - New_Spec : Node_Id; + DTW_Body : Node_Id; + DTW_Decl : Node_Id; + DTW_Id : Entity_Id; + DTW_Spec : Node_Id; begin -- The wrapper must be analyzed in the scope of its wrapped @@ -1665,47 +1912,130 @@ package body Freeze is Push_Scope (Scope (Prim)); - New_Spec := Build_Overriding_Spec (Par_Prim, R); - New_Id := Defining_Entity (New_Spec); - New_Decl := - Make_Subprogram_Declaration (Loc, - Specification => New_Spec); - - -- Insert the declaration and the body of the wrapper after - -- type declaration that generates inherited operation. For - -- a null procedure, the declaration implies a null body. + DTW_Spec := Build_DTW_Spec (Par_Prim); + DTW_Id := Defining_Entity (DTW_Spec); + DTW_Decl := Make_Subprogram_Declaration (Loc, + Specification => DTW_Spec); + + -- For inherited class-wide preconditions the DTW wrapper + -- reuses the ICW of the parent (which checks the parent + -- interpretation of the class-wide preconditions); the + -- interpretation of the class-wide preconditions for the + -- inherited subprogram is checked at the caller side. + + -- When the subprogram inherits class-wide postconditions + -- the DTW also checks the interpretation of the class-wide + -- postconditions for the inherited subprogram, and the body + -- of the parent checks its interpretation of the parent for + -- the class-wide postconditions. + + -- procedure Prim (F1 : T1; ...) is + -- [ pragma Check (Postcondition, Expr); ] + -- begin + -- Par_Prim_ICW (Par_Type (F1), ...); + -- end; + + if Present (Indirect_Call_Wrapper (Par_Prim)) then + DTW_Body := + Build_DTW_Body (Loc, + DTW_Spec => DTW_Spec, + DTW_Decls => Decls, + Par_Prim => Par_Prim, + Wrapped_Subp => Indirect_Call_Wrapper (Par_Prim)); + + -- For subprograms that only inherit class-wide postconditions + -- the DTW wrapper calls the parent primitive (which on its + -- body checks the interpretation of the class-wide post- + -- conditions for the parent subprogram), and the DTW checks + -- the interpretation of the class-wide postconditions for the + -- inherited subprogram. + + -- procedure Prim (F1 : T1; ...) is + -- pragma Check (Postcondition, Expr); + -- begin + -- Par_Prim (Par_Type (F1), ...); + -- end; - -- Before insertion, do some minimal decoration of fields + else + DTW_Body := + Build_DTW_Body (Loc, + DTW_Spec => DTW_Spec, + DTW_Decls => Decls, + Par_Prim => Par_Prim, + Wrapped_Subp => Par_Prim); + end if; - Mutate_Ekind (New_Id, Ekind (Par_Prim)); - Set_LSP_Subprogram (New_Id, Par_Prim); - Set_Is_Wrapper (New_Id); + -- Insert the declaration of the wrapper before the freezing + -- node of the record type declaration to ensure that it will + -- override the internal primitive built by Derive_Subprogram. - if Nkind (New_Spec) = N_Procedure_Specification - and then Null_Present (New_Spec) - then - Insert_After_And_Analyze (Par_R, New_Decl); + Ensure_Freeze_Node (R); + if Late_Overriding then + Insert_Before_And_Analyze (Freeze_Node (R), DTW_Decl); else - -- Build body as wrapper to a call to the already built - -- class-wide clone. + Append_Freeze_Action (R, DTW_Decl); + end if; + + Analyze (DTW_Decl); + + -- Insert the body of the wrapper in the freeze actions of + -- its record type declaration to ensure that it is placed + -- in the scope of its declaration but not too early to cause + -- premature freezing of other entities. + + Append_Freeze_Action (R, DTW_Body); + Analyze (DTW_Body); + + -- Ensure correct decoration + + pragma Assert (Is_Dispatching_Operation (DTW_Id)); + pragma Assert (Present (Overridden_Operation (DTW_Id))); + pragma Assert (Overridden_Operation (DTW_Id) = Alias_Id); - New_Body := - Build_Class_Wide_Clone_Call - (Loc, Decls, Par_Prim, New_Spec); + -- Inherit dispatch table slot - Insert_List_After_And_Analyze - (Par_R, New_List (New_Decl, New_Body)); + Set_DTC_Entity_Value (R, DTW_Id); + Set_DT_Position (DTW_Id, DT_Position (Alias_Id)); - -- Ensure correct decoration + -- Register the wrapper in the dispatch table - pragma Assert (Present (Alias (Prim))); - pragma Assert (Present (Overridden_Operation (New_Id))); - pragma Assert (Overridden_Operation (New_Id) = Alias_Id); + if Late_Overriding + and then not Building_Static_DT (R) + then + Insert_List_After_And_Analyze (Freeze_Node (R), + Register_Primitive (Loc, DTW_Id)); end if; - pragma Assert (Is_Dispatching_Operation (Prim)); - pragma Assert (Is_Dispatching_Operation (New_Id)); + -- Build the helper and ICW for the DTW + + if Present (Indirect_Call_Wrapper (Par_Prim)) then + declare + CW_Subp : Entity_Id; + Decl_N : Node_Id; + Body_N : Node_Id; + + begin + Merge_Class_Conditions (DTW_Id); + Make_Class_Precondition_Subps (DTW_Id, + Late_Overriding => Late_Overriding); + + CW_Subp := Static_Call_Helper (DTW_Id); + Decl_N := Unit_Declaration_Node (CW_Subp); + Analyze (Decl_N); + + -- If the DTW was built for a late-overriding primitive + -- its body must be analyzed now (since the tagged type + -- is already frozen). + + if Late_Overriding then + Body_N := + Unit_Declaration_Node + (Corresponding_Body (Decl_N)); + Analyze (Body_N); + end if; + end; + end if; Pop_Scope; end; @@ -7398,7 +7728,7 @@ package body Freeze is if Is_Type (E) then Freeze_And_Append (First_Subtype (E), N, Result); - -- If we just froze a tagged non-class wide record, then freeze the + -- If we just froze a tagged non-class-wide record, then freeze the -- corresponding class-wide type. This must be done after the tagged -- type itself is frozen, because the class-wide type refers to the -- tagged type which generates the class. @@ -10062,7 +10392,7 @@ package body Freeze is -- Warn_Overlay -- ------------------ - procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Entity_Id) is + procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id) is Ent : constant Entity_Id := Entity (Nam); -- The object to which the address clause applies diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 6f4feca..0174756 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -174,6 +174,15 @@ package Freeze is -- do not allow a size clause if the size would not otherwise be known at -- compile time in any case. + procedure Check_Inherited_Conditions + (R : Entity_Id; + Late_Overriding : Boolean := False); + -- For a tagged derived type R, create wrappers for inherited operations + -- that have class-wide conditions, so it can be properly rewritten if + -- it involves calls to other overriding primitives. Late_Overriding is + -- True when we are processing the body of a primitive with no previous + -- spec defined after R is frozen (see Check_Dispatching_Operation). + 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 diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index c341e2d..61a627f 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -517,7 +517,6 @@ GNAT_ADA_OBJS+= \ ada/libgnat/s-excmac.o \ ada/libgnat/s-exctab.o \ ada/libgnat/s-htable.o \ - ada/libgnat/s-imenne.o \ ada/libgnat/s-imgint.o \ ada/libgnat/s-mastop.o \ ada/libgnat/s-memory.o \ @@ -684,7 +683,6 @@ GNATBIND_OBJS += \ ada/libgnat/s-excmac.o \ ada/libgnat/s-exctab.o \ ada/libgnat/s-htable.o \ - ada/libgnat/s-imenne.o \ ada/libgnat/s-imgint.o \ ada/libgnat/s-mastop.o \ ada/libgnat/s-memory.o \ diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c index 6ac82d7..abf8d46 100644 --- a/gcc/ada/gcc-interface/cuintp.c +++ b/gcc/ada/gcc-interface/cuintp.c @@ -39,6 +39,7 @@ #include "ada.h" #include "types.h" #include "uintp.h" +#include "sinfo.h" #include "ada-tree.h" #include "gigi.h" diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 884d1d8..13e9004 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -557,7 +557,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If the entity is an inherited component (in the case of extended tagged record types), just return the original entity, which must be a FIELD_DECL. Likewise for discriminants. If the entity is a - non-girder discriminant (in the case of derived untagged record + non-stored discriminant (in the case of derived untagged record types), return the stored discriminant it renames. */ if (Present (Original_Record_Component (gnat_entity)) && Original_Record_Component (gnat_entity) != gnat_entity) @@ -6503,7 +6503,8 @@ range_cannot_be_superflat (Node_Id gnat_range) Node_Id gnat_scalar_range; tree gnu_lb, gnu_hb, gnu_lb_minus_one; - /* If the low bound is not constant, try to find an upper bound. */ + /* If the low bound is not constant, take the worst case by finding an upper + bound for its type, repeatedly if need be. */ while (Nkind (gnat_lb) != N_Integer_Literal && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype) @@ -6512,7 +6513,8 @@ range_cannot_be_superflat (Node_Id gnat_range) || Nkind (gnat_scalar_range) == N_Range)) gnat_lb = High_Bound (gnat_scalar_range); - /* If the high bound is not constant, try to find a lower bound. */ + /* If the high bound is not constant, take the worst case by finding a lower + bound for its type, repeatedly if need be. */ while (Nkind (gnat_hb) != N_Integer_Literal && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype) diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 49b85a4..692ef44 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -234,7 +234,7 @@ extern "C" { extern void gigi (Node_Id gnat_root, int max_gnat_node, int number_name, - Field_Offset *node_offsets_ptr, + Node_Header *node_offsets_ptr, any_slot *slots_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c index 704172d..fb103a1 100644 --- a/gcc/ada/gcc-interface/targtyps.c +++ b/gcc/ada/gcc-interface/targtyps.c @@ -34,6 +34,7 @@ #include "ada.h" #include "types.h" +#include "sinfo.h" #include "ada-tree.h" #include "gigi.h" diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index d3c421d..3fec060 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -75,7 +75,7 @@ #define ALLOCA_THRESHOLD 1000 /* Pointers to front-end tables accessed through macros. */ -Field_Offset *Node_Offsets_Ptr; +Node_Header *Node_Offsets_Ptr; any_slot *Slots_Ptr; Node_Id *Next_Node_Ptr; Node_Id *Prev_Node_Ptr; @@ -279,7 +279,7 @@ void gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, - Field_Offset *node_offsets_ptr, + Node_Header *node_offsets_ptr, any_slot *slots_ptr, Node_Id *next_node_ptr, Node_Id *prev_node_ptr, @@ -3893,7 +3893,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) /* If the body comes from an expression function, arrange it to be inlined in almost all cases. */ - if (Was_Expression_Function (gnat_node)) + if (Was_Expression_Function (gnat_node) && !Debug_Flag_Dot_8) DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl) = 1; /* Try to create a bona-fide thunk and hand it over to the middle-end. */ @@ -8261,6 +8261,7 @@ gnat_to_gnu (Node_Id gnat_node) || kind == N_Selected_Component) && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE && Nkind (Parent (gnat_node)) != N_Attribute_Reference + && Nkind (Parent (gnat_node)) != N_Pragma_Argument_Association && Nkind (Parent (gnat_node)) != N_Variant_Part && !lvalue_required_p (gnat_node, gnu_result_type, false, false)) { @@ -10507,10 +10508,15 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) case N_Package_Body: case N_Subprogram_Body: case N_Block_Statement: - gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); + if (Present (Handled_Statement_Sequence (gnat_node))) + gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); + else + gnat_end_label = Empty; + break; case N_Package_Declaration: + gcc_checking_assert (Present (Specification (gnat_node))); gnat_end_label = End_Label (Specification (gnat_node)); break; diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index be3f107..ab5ca5b 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -94,6 +94,7 @@ 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_strub_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 *); @@ -157,6 +158,8 @@ const struct attribute_spec gnat_internal_attribute_table[] = { "no_stack_protector",0, 0, true, false, false, false, handle_no_stack_protector_attribute, attr_stack_protect_exclusions }, + { "strub", 0, 1, false, true, false, true, + handle_strub_attribute, NULL }, { "noinline", 0, 0, true, false, false, false, handle_noinline_attribute, NULL }, { "noclone", 0, 0, true, false, false, false, @@ -6602,6 +6605,15 @@ handle_no_stack_protector_attribute (tree *node, tree name, tree, int, return NULL_TREE; } +/* Handle a "strub" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_strub_attribute (tree *, tree, tree, int, bool *no_add_attrs) +{ + *no_add_attrs = true; + return NULL_TREE; +} /* Handle a "noinline" attribute; arguments as in struct attribute_spec.handler. */ diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 360e2e1..f3f3ca4 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -23,8 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Gen_IL.Types; - package Gen_IL.Fields is -- The following is "optional field enumeration" -- i.e. it is Field_Enum @@ -36,8 +34,7 @@ package Gen_IL.Fields is -- which might need to be kept in sync when modifying this. -- Be sure to put new fields in the appropriate subrange (Field_Enum, - -- Node_Header_Field, Node_Field, Entity_Field -- search for comments - -- below). + -- Node_Field, Entity_Field -- search for comments below). type Opt_Field_Enum is (No_Field, @@ -461,7 +458,9 @@ package Gen_IL.Fields is Can_Never_Be_Null, Can_Use_Internal_Rep, Checks_May_Be_Suppressed, - Class_Wide_Clone, + Class_Postconditions, + Class_Preconditions, + Class_Preconditions_Subprogram, Class_Wide_Type, Cloned_Subtype, Component_Alignment, @@ -509,6 +508,7 @@ package Gen_IL.Fields is Discriminant_Default_Value, Discriminant_Number, Dispatch_Table_Wrappers, + Dynamic_Call_Helper, DT_Entry_Count, DT_Offset_To_Top_Func, DT_Position, @@ -649,9 +649,12 @@ package Gen_IL.Fields is Hiding_Loop_Variable, Hidden_In_Formal_Instance, Homonym, + Ignored_Class_Postconditions, + Ignored_Class_Preconditions, Ignore_SPARK_Mode_Pragmas, Import_Pragma, Incomplete_Actuals, + Indirect_Call_Wrapper, In_Package_Body, In_Private_Part, In_Use, @@ -677,6 +680,7 @@ package Gen_IL.Fields is Is_Checked_Ghost_Entity, Is_Child_Unit, Is_Class_Wide_Equivalent_Type, + Is_Class_Wide_Wrapper, Is_Compilation_Unit, Is_Completely_Hidden, Is_Concurrent_Record_Type, @@ -693,6 +697,7 @@ package Gen_IL.Fields is Is_Discrim_SO_Function, Is_Discriminant_Check_Function, Is_Dispatch_Table_Entity, + Is_Dispatch_Table_Wrapper, Is_Dispatching_Operation, Is_Elaboration_Checks_OK_Id, Is_Elaboration_Warnings_OK_Id, @@ -892,6 +897,7 @@ package Gen_IL.Fields is Spec_Entity, SSO_Set_High_By_Default, SSO_Set_Low_By_Default, + Static_Call_Helper, Static_Discrete_Predicate, Static_Elaboration_Desired, Static_Initialization, @@ -935,13 +941,4 @@ package Gen_IL.Fields is -- Enumeration of fields -- Opt_Field_Enum without the special null value -- No_Field. - subtype Node_Header_Field is Field_Enum with Predicate => - Node_Header_Field in Nkind .. Link | Ekind; - - use Gen_IL.Types; - - subtype Node_Header_Type is Type_Enum range - Node_Kind_Type .. Union_Id; - -- Types of node header fields - end Gen_IL.Fields; diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index bca0549..1fa7f0b 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -126,6 +126,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Character_Type, Flag), Sm (Is_Checked_Ghost_Entity, Flag), Sm (Is_Child_Unit, Flag), + Sm (Is_Class_Wide_Wrapper, Flag), Sm (Is_Class_Wide_Equivalent_Type, Flag), Sm (Is_Compilation_Unit, Flag), Sm (Is_Concurrent_Record_Type, Flag), @@ -139,6 +140,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Discrim_SO_Function, Flag), Sm (Is_Discriminant_Check_Function, Flag), Sm (Is_Dispatch_Table_Entity, Flag), + Sm (Is_Dispatch_Table_Wrapper, Flag), Sm (Is_Dispatching_Operation, Flag), Sm (Is_Eliminated, Flag), Sm (Is_Entry_Formal, Flag), @@ -977,8 +979,11 @@ begin -- Gen_IL.Gen.Gen_Entities Ab (Subprogram_Kind, Overloadable_Kind, (Sm (Body_Needed_For_SAL, Flag), - Sm (Class_Wide_Clone, Node_Id), + Sm (Class_Postconditions, Node_Id), + Sm (Class_Preconditions, Node_Id), + Sm (Class_Preconditions_Subprogram, Node_Id), Sm (Contract, Node_Id), + Sm (Dynamic_Call_Helper, Node_Id), Sm (Elaboration_Entity, Node_Id), Sm (Elaboration_Entity_Required, Flag), Sm (First_Entity, Node_Id), @@ -986,8 +991,11 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Has_Nested_Subprogram, Flag), Sm (Has_Out_Or_In_Out_Parameter, Flag), Sm (Has_Recursive_Call, Flag), + Sm (Ignored_Class_Postconditions, Node_Id), + Sm (Ignored_Class_Preconditions, Node_Id), Sm (Ignore_SPARK_Mode_Pragmas, Flag), Sm (Import_Pragma, Node_Id), + Sm (Indirect_Call_Wrapper, Node_Id), Sm (Interface_Alias, Node_Id), Sm (Interface_Name, Node_Id), Sm (Is_Elaboration_Checks_OK_Id, Flag), @@ -998,6 +1006,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Overridden_Operation, Node_Id), Sm (Protected_Body_Subprogram, Node_Id), Sm (Scope_Depth_Value, Uint), + Sm (Static_Call_Helper, Node_Id), Sm (SPARK_Pragma, Node_Id), Sm (SPARK_Pragma_Inherited, Flag), Sm (Subps_Index, Uint))); @@ -1383,6 +1392,23 @@ begin -- Gen_IL.Gen.Gen_Entities (E_Entry, E_Entry_Family)); + Union (Evaluable_Kind, + Children => + (Exception_Or_Object_Kind, + E_Enumeration_Literal, + E_Label, + Subprogram_Kind)); + -- Kinds that represent values that can be evaluated + + Union (Global_Name_Kind, + Children => + (Constant_Or_Variable_Kind, + E_Exception, + E_Package, + Subprogram_Kind)); + -- Kinds that can have an Interface_Name that corresponds to a global + -- (linker) name. + Union (Named_Access_Kind, Children => (E_Access_Type, @@ -1408,4 +1434,10 @@ begin -- Gen_IL.Gen.Gen_Entities E_Record_Type_With_Private, E_Record_Subtype_With_Private)); + Union (Subprogram_Type_Or_Kind, + Children => + (Subprogram_Kind, + E_Subprogram_Body, + E_Subprogram_Type)); + end Gen_IL.Gen.Gen_Entities; diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 55ba71d..20d25ea 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -577,7 +577,8 @@ begin -- Gen_IL.Gen.Gen_Nodes Ab (N_Declaration, Node_Kind); -- Note: this includes all constructs normally thought of as declarations - -- except those that are separately grouped in N_Later_Decl_Item. + -- except those that are separately grouped in N_Later_Decl_Item. But + -- Declaration_Node may return yet more node types; see N_Is_Decl below. Cc (N_Component_Declaration, N_Declaration, (Sy (Defining_Identifier, Node_Id), @@ -1649,4 +1650,67 @@ begin -- Gen_IL.Gen.Gen_Nodes N_Terminate_Alternative)); -- Nodes with condition fields (does not include N_Raise_xxx_Error) + Union (N_Has_Bounds, + Children => + (N_Range, + N_Real_Range_Specification, + N_Signed_Integer_Type_Definition)); + -- Nodes that have Low_Bound and High_Bound defined + + Union (N_Is_Index, + Children => + (N_Has_Bounds, + N_Has_Entity, + N_Subtype_Indication)); + -- Nodes that can be an index of an array + + Union (N_Entity_Name, + Children => + (N_Expanded_Name, + N_Identifier, + N_Operator_Symbol)); + -- Nodes that are definitely representing an entity. + -- Some N_Attribute_Reference nodes may also represent an entity. See + -- Is_Entity_Name. + + Union (N_Is_Decl, + Children => + (N_Declaration, + N_Discriminant_Specification, + N_Enumeration_Type_Definition, + N_Exception_Handler, + N_Later_Decl_Item, + N_Package_Specification, + N_Parameter_Specification, + N_Renaming_Declaration, + N_Subprogram_Specification)); + -- Nodes that can be returned by Declaration_Node + + Union (N_Is_Range, + Children => + (N_Character_Literal, + N_Entity_Name, + N_Has_Bounds, + N_Integer_Literal, + N_Subtype_Indication)); + -- Nodes that can be used to specify a range + + Union (N_Is_Case_Choice, + Children => + (N_Is_Range, + N_Others_Choice)); + -- Nodes that can be in the choices of a case statement + + Union (N_Is_Exception_Choice, + Children => + (N_Entity_Name, + N_Others_Choice)); + -- Nodes that can be in the choices of an exception handler + + Union (N_Alternative, + Children => + (N_Case_Statement_Alternative, + N_Variant)); + -- Nodes that can be alternatives in case contructs + end Gen_IL.Gen.Gen_Nodes; diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb index 3bb9807..e786251 100644 --- a/gcc/ada/gen_il-gen.adb +++ b/gcc/ada/gen_il-gen.adb @@ -28,6 +28,27 @@ with Ada.Text_IO; package body Gen_IL.Gen is + Statistics_Enabled : constant Boolean := False; + -- Change to True or False to enable/disable statistics printed by + -- Atree. Should normally be False, for efficiency. Also compile with + -- -gnatd.A to get the statistics printed. Enabling these statistics + -- makes the compiler about 20% slower. + + Num_Header_Slots : constant := 3; + -- Number of header slots; the first Num_Header_Slots slots are stored in + -- the header; the rest are dynamically allocated in the Slots table. We + -- need to subtract this off when accessing dynamic slots. The constant + -- Seinfo.N_Head will contain this value. Fields that are allocated in the + -- header slots are quicker to access. + -- + -- This number can be adjusted for efficiency. We choose 3 because the + -- minimum node size is 3 slots, and because that causes the size of type + -- Node_Header to be a power of 2. We can't make it zero, however, because + -- C doesn't allow zero-length arrays. + + N_Head : constant String := Image (Field_Offset'(Num_Header_Slots)); + -- String form of the above + Enable_Assertions : constant Boolean := True; -- True to enable predicates on the _Id types, and preconditions on getters -- and setters. @@ -37,6 +58,9 @@ package body Gen_IL.Gen is -- which results in enormous nodes. For experimenting and debugging. -- Should be True in normal operation, for efficiency. + SS : constant := 32; -- slot size in bits + SSS : constant String := Image (Bit_Offset'(SS)); + Inline : constant String := "Inline"; -- For experimenting with Inline_Always @@ -309,7 +333,7 @@ package body Gen_IL.Gen is Pre => new String'(Pre), Pre_Get => new String'(Pre_Get), Pre_Set => new String'(Pre_Set), - Offset => <>); -- filled in later + Offset => Unknown_Offset); -- The Field_Table entry has already been created by the 'then' part -- above. Now we're seeing the same field being "created" again in a @@ -479,8 +503,6 @@ package body Gen_IL.Gen is Min_Entity_Size : Field_Offset := Field_Offset'Last; Max_Entity_Size : Field_Offset := 0; - Average_Node_Size_In_Slots : Long_Float; - Node_Field_Types_Used, Entity_Field_Types_Used : Type_Set; Setter_Needs_Parent : Field_Set := @@ -563,6 +585,8 @@ package body Gen_IL.Gen is procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum); procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum); procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum); + procedure Put_Getter_Setter_Locals + (S : in out Sink; F : Field_Enum; Get : Boolean); procedure Put_Getter_Body (S : in out Sink; F : Field_Enum); procedure Put_Setter_Body (S : in out Sink; F : Field_Enum); -- Print out the specification, declaration, or body of a getter or @@ -573,9 +597,9 @@ package body Gen_IL.Gen is -- Print out the precondition, if any, for a getter or setter for the -- given field. - procedure Put_Low_Level_Accessor_Instantiations + procedure Put_Casts (S : in out Sink; T : Type_Enum); - -- Print out the low-level getter and setter for a given type + -- Print out the Cast functions for a given type procedure Put_Traversed_Fields (S : in out Sink); -- Called by Put_Nodes to print out the Traversed_Fields table in @@ -616,22 +640,17 @@ package body Gen_IL.Gen is -- corresponding to the Ada Node_Kind, Entity_Kind, and subtypes -- thereof. - procedure Put_Low_Level_C_Getter - (S : in out Sink; T : Type_Enum); - -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out low-level - -- getters. - - procedure Put_High_Level_C_Getters + procedure Put_C_Getters (S : in out Sink; Root : Root_Type); -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out high-level -- getters. - procedure Put_High_Level_C_Getter + procedure Put_C_Getter (S : in out Sink; F : Field_Enum); - -- Used by Put_High_Level_C_Getters to print out one high-level getter. + -- Used by Put_C_Getters to print out one high-level getter. procedure Put_Union_Membership - (S : in out Sink; Root : Root_Type); + (S : in out Sink; Root : Root_Type; Only_Prototypes : Boolean); -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out functions to -- test membership in a union type. @@ -691,6 +710,8 @@ package body Gen_IL.Gen is Type_Table (T).Last := T; Add_Concrete_Descendant_To_Ancestors (Type_Table (T).Parent, T); + -- Parent cannot be No_Type here, because T is a concrete + -- type, and therefore not a root type. when Abstract_Type => declare @@ -884,13 +905,13 @@ package body Gen_IL.Gen is function To_Size_In_Slots (Size_In_Bits : Bit_Offset) return Field_Offset is - ((Field_Offset (Size_In_Bits) + 31) / 32); + ((Field_Offset (Size_In_Bits) + (SS - 1)) / SS); function Type_Size_In_Slots (T : Concrete_Type) return Field_Offset is (To_Size_In_Slots (Type_Bit_Size (T))); -- rounded up to slot boundary function Type_Bit_Size_Aligned (T : Concrete_Type) return Bit_Offset is - (Bit_Offset (Type_Size_In_Slots (T)) * 32); -- multiple of slot size + (Bit_Offset (Type_Size_In_Slots (T)) * SS); -- multiple of slot size --------------------------- -- Compute_Field_Offsets -- @@ -924,8 +945,7 @@ package body Gen_IL.Gen is (F : Field_Enum; Offset : Field_Offset); -- Mark the offset as "in use" - function Choose_Offset - (F : Field_Enum) return Field_Offset; + procedure Choose_Offset (F : Field_Enum); -- Choose an offset for this field function Offset_OK @@ -965,14 +985,14 @@ package body Gen_IL.Gen is end loop; end Set_Offset_In_Use; - function Choose_Offset - (F : Field_Enum) return Field_Offset is + procedure Choose_Offset (F : Field_Enum) is begin for Offset in Field_Offset loop if Offset_OK (F, Offset) then Set_Offset_In_Use (F, Offset); - return Offset; + Field_Table (F).Offset := Offset; + return; end if; end loop; @@ -981,16 +1001,16 @@ package body Gen_IL.Gen is Image (Gen_IL.Internals.Bit_Offset'Last) & " is too small)"; end Choose_Offset; - Num_Concrete_Have_Field : array (Field_Enum) of Type_Count := + Weighted_Node_Frequency : array (Field_Enum) of Type_Count := (others => 0); -- Number of concrete types that have each field function More_Types_Have_Field (F1, F2 : Field_Enum) return Boolean is - (Num_Concrete_Have_Field (F1) > Num_Concrete_Have_Field (F2)); + (Weighted_Node_Frequency (F1) > Weighted_Node_Frequency (F2)); -- True if F1 appears in more concrete types than F2 function Sort_Less (F1, F2 : Field_Enum) return Boolean is - (if Num_Concrete_Have_Field (F1) = Num_Concrete_Have_Field (F2) then + (if Weighted_Node_Frequency (F1) = Weighted_Node_Frequency (F2) then F1 < F2 else More_Types_Have_Field (F1, F2)); @@ -999,15 +1019,18 @@ package body Gen_IL.Gen is All_Fields : Field_Vector; + -- Start of processing for Compute_Field_Offsets + begin - -- Compute the number of types that have each field + -- Compute the number of types that have each field, weighted by the + -- frequency of such nodes. for T in Concrete_Type loop for F in Field_Enum loop if Fields_Per_Node (T) (F) then - Num_Concrete_Have_Field (F) := - Num_Concrete_Have_Field (F) + 1; + Weighted_Node_Frequency (F) := + Weighted_Node_Frequency (F) + Type_Frequency (T); end if; end loop; end loop; @@ -1038,8 +1061,33 @@ package body Gen_IL.Gen is -- complication compared to standard graph coloring is that fields -- are different sizes. + -- First choose offsets for some heavily-used fields, so they will + -- get low offsets, so they will wind up in the node header for + -- faster access. + + Choose_Offset (Nkind); + pragma Assert (Field_Table (Nkind).Offset = 0); + Choose_Offset (Ekind); + pragma Assert (Field_Table (Ekind).Offset = 1); + Choose_Offset (Homonym); + pragma Assert (Field_Table (Homonym).Offset = 1); + Choose_Offset (Is_Immediately_Visible); + pragma Assert (Field_Table (Is_Immediately_Visible).Offset = 16); + Choose_Offset (From_Limited_With); + pragma Assert (Field_Table (From_Limited_With).Offset = 17); + Choose_Offset (Is_Potentially_Use_Visible); + pragma Assert (Field_Table (Is_Potentially_Use_Visible).Offset = 18); + Choose_Offset (Is_Generic_Instance); + pragma Assert (Field_Table (Is_Generic_Instance).Offset = 19); + Choose_Offset (Scope); + pragma Assert (Field_Table (Scope).Offset = 2); + + -- Then loop through them all, skipping the ones we did above + for F of All_Fields loop - Field_Table (F).Offset := Choose_Offset (F); + if Field_Table (F).Offset = Unknown_Offset then + Choose_Offset (F); + end if; end loop; end Compute_Field_Offsets; @@ -1049,231 +1097,6 @@ package body Gen_IL.Gen is ------------------------ procedure Compute_Type_Sizes is - -- Node_Counts is the number of nodes of each kind created during - -- compilation of a large example. This is used purely to compute an - -- estimate of the average node size. New node types can default to - -- "others => 0". At some point we can instrument Atree to print out - -- accurate size statistics, and remove this code. - - Node_Counts : constant array (Concrete_Node) of Natural := - (N_Identifier => 429298, - N_Defining_Identifier => 231636, - N_Integer_Literal => 90892, - N_Parameter_Specification => 62811, - N_Attribute_Reference => 47150, - N_Expanded_Name => 37375, - N_Selected_Component => 30699, - N_Subprogram_Declaration => 20744, - N_Freeze_Entity => 20314, - N_Procedure_Specification => 18901, - N_Object_Declaration => 18023, - N_Function_Specification => 16570, - N_Range => 16216, - N_Explicit_Dereference => 12198, - N_Component_Association => 11188, - N_Unchecked_Type_Conversion => 11165, - N_Subtype_Indication => 10727, - N_Procedure_Call_Statement => 10056, - N_Subtype_Declaration => 8141, - N_Handled_Sequence_Of_Statements => 8078, - N_Null => 7288, - N_Aggregate => 7222, - N_String_Literal => 7152, - N_Function_Call => 6958, - N_Simple_Return_Statement => 6911, - N_And_Then => 6867, - N_Op_Eq => 6845, - N_Call_Marker => 6683, - N_Pragma_Argument_Association => 6525, - N_Component_Definition => 6487, - N_Assignment_Statement => 6483, - N_With_Clause => 6480, - N_Null_Statement => 5917, - N_Index_Or_Discriminant_Constraint => 5877, - N_Generic_Association => 5667, - N_Full_Type_Declaration => 5573, - N_If_Statement => 5553, - N_Subprogram_Body => 5455, - N_Op_Add => 5443, - N_Type_Conversion => 5260, - N_Component_Declaration => 5059, - N_Raise_Constraint_Error => 4840, - N_Formal_Concrete_Subprogram_Declaration => 4602, - N_Expression_With_Actions => 4598, - N_Op_Ne => 3854, - N_Indexed_Component => 3834, - N_Op_Subtract => 3777, - N_Package_Specification => 3490, - N_Subprogram_Renaming_Declaration => 3445, - N_Pragma => 3427, - N_Case_Statement_Alternative => 3272, - N_Block_Statement => 3239, - N_Parameter_Association => 3213, - N_Op_Lt => 3020, - N_Op_Not => 2926, - N_Character_Literal => 2914, - N_Others_Choice => 2769, - N_Or_Else => 2576, - N_Itype_Reference => 2511, - N_Defining_Operator_Symbol => 2487, - N_Component_List => 2470, - N_Formal_Object_Declaration => 2262, - N_Generic_Subprogram_Declaration => 2227, - N_Real_Literal => 2156, - N_Op_Gt => 2156, - N_Access_To_Object_Definition => 1984, - N_Op_Le => 1975, - N_Op_Ge => 1942, - N_Package_Renaming_Declaration => 1811, - N_Formal_Type_Declaration => 1756, - N_Qualified_Expression => 1746, - N_Package_Declaration => 1729, - N_Record_Definition => 1651, - N_Allocator => 1521, - N_Op_Concat => 1377, - N_Access_Definition => 1358, - N_Case_Statement => 1322, - N_Number_Declaration => 1316, - N_Generic_Package_Declaration => 1311, - N_Slice => 1078, - N_Constrained_Array_Definition => 1068, - N_Exception_Renaming_Declaration => 1011, - N_Implicit_Label_Declaration => 978, - N_Exception_Handler => 966, - N_Private_Type_Declaration => 898, - N_Operator_Symbol => 872, - N_Formal_Private_Type_Definition => 867, - N_Range_Constraint => 849, - N_Aspect_Specification => 837, - N_Variant => 834, - N_Discriminant_Specification => 746, - N_Loop_Statement => 744, - N_Derived_Type_Definition => 731, - N_Freeze_Generic_Entity => 702, - N_Iteration_Scheme => 686, - N_Package_Instantiation => 658, - N_Loop_Parameter_Specification => 632, - N_Attribute_Definition_Clause => 608, - N_Compilation_Unit_Aux => 599, - N_Compilation_Unit => 599, - N_Label => 572, - N_Goto_Statement => 572, - N_In => 564, - N_Enumeration_Type_Definition => 523, - N_Object_Renaming_Declaration => 482, - N_If_Expression => 476, - N_Exception_Declaration => 472, - N_Reference => 455, - N_Incomplete_Type_Declaration => 438, - N_Use_Package_Clause => 401, - N_Unconstrained_Array_Definition => 360, - N_Variant_Part => 340, - N_Defining_Program_Unit_Name => 336, - N_Op_And => 334, - N_Raise_Program_Error => 329, - N_Formal_Discrete_Type_Definition => 319, - N_Contract => 311, - N_Not_In => 305, - N_Designator => 285, - N_Component_Clause => 247, - N_Formal_Signed_Integer_Type_Definition => 244, - N_Raise_Statement => 214, - N_Op_Expon => 205, - N_Op_Minus => 202, - N_Op_Multiply => 158, - N_Exit_Statement => 130, - N_Function_Instantiation => 129, - N_Discriminant_Association => 123, - N_Private_Extension_Declaration => 119, - N_Extended_Return_Statement => 117, - N_Op_Divide => 107, - N_Op_Or => 103, - N_Signed_Integer_Type_Definition => 101, - N_Record_Representation_Clause => 76, - N_Unchecked_Expression => 70, - N_Op_Abs => 63, - N_Elsif_Part => 62, - N_Formal_Floating_Point_Definition => 59, - N_Formal_Package_Declaration => 58, - N_Modular_Type_Definition => 55, - N_Abstract_Subprogram_Declaration => 52, - N_Validate_Unchecked_Conversion => 49, - N_Defining_Character_Literal => 36, - N_Raise_Storage_Error => 33, - N_Compound_Statement => 29, - N_Procedure_Instantiation => 28, - N_Access_Procedure_Definition => 25, - N_Floating_Point_Definition => 20, - N_Use_Type_Clause => 19, - N_Op_Plus => 14, - N_Package_Body => 13, - N_Op_Rem => 13, - N_Enumeration_Representation_Clause => 13, - N_Access_Function_Definition => 11, - N_Extension_Aggregate => 11, - N_Formal_Ordinary_Fixed_Point_Definition => 10, - N_Op_Mod => 10, - N_Expression_Function => 9, - N_Delay_Relative_Statement => 9, - N_Quantified_Expression => 7, - N_Formal_Derived_Type_Definition => 7, - N_Free_Statement => 7, - N_Iterator_Specification => 5, - N_Op_Shift_Left => 5, - N_Formal_Modular_Type_Definition => 4, - N_Generic_Package_Renaming_Declaration => 1, - N_Empty => 1, - N_Real_Range_Specification => 1, - N_Ordinary_Fixed_Point_Definition => 1, - N_Op_Shift_Right => 1, - N_Error => 1, - N_Mod_Clause => 1, - others => 0); - - Total_Node_Count : constant Long_Float := 1370676.0; - - type Node_Frequency_Table is array (Concrete_Node) of Long_Float; - - function Init_Node_Frequency return Node_Frequency_Table; - -- Compute the value of the Node_Frequency table - - function Average_Type_Size_In_Slots return Long_Float; - -- Compute the average over all concrete node types of the size, - -- weighted by the frequency of that node type. - - function Init_Node_Frequency return Node_Frequency_Table is - Result : Node_Frequency_Table := (others => 0.0); - - begin - for T in Concrete_Node loop - Result (T) := Long_Float (Node_Counts (T)) / Total_Node_Count; - end loop; - - return Result; - end Init_Node_Frequency; - - Node_Frequency : constant Node_Frequency_Table := Init_Node_Frequency; - -- Table mapping concrete node types to the relative frequency of - -- that node, in our large example. The sum of these values should - -- add up to approximately 1.0. For example, if Node_Frequency(K) = - -- 0.02, then that means that approximately 2% of all nodes are K - -- nodes. - - function Average_Type_Size_In_Slots return Long_Float is - -- We don't have data on entities, so we leave those out - - Result : Long_Float := 0.0; - begin - for T in Concrete_Node loop - Result := Result + - Node_Frequency (T) * Long_Float (Type_Size_In_Slots (T)); - end loop; - - return Result; - end Average_Type_Size_In_Slots; - - -- Start of processing for Compute_Type_Sizes - begin for T in Concrete_Type loop declare @@ -1289,7 +1112,10 @@ package body Gen_IL.Gen is end if; end loop; - Type_Bit_Size (T) := Max_Offset + 1; + -- No type can be smaller than the header slots + + Type_Bit_Size (T) := + Bit_Offset'Max (Max_Offset + 1, SS * Num_Header_Slots); end; end loop; @@ -1311,8 +1137,6 @@ package body Gen_IL.Gen is Max_Node_Size := To_Size_In_Slots (Max_Node_Bit_Size); Min_Entity_Size := To_Size_In_Slots (Min_Entity_Bit_Size); Max_Entity_Size := To_Size_In_Slots (Max_Entity_Bit_Size); - - Average_Node_Size_In_Slots := Average_Type_Size_In_Slots; end Compute_Type_Sizes; ---------------------------------------- @@ -1533,7 +1357,7 @@ package body Gen_IL.Gen is case Root is when Node_Kind => Put_Getter_Decl (S, Nkind); - Put (S, "function K (N : Node_Id) return Node_Kind renames Nkind;" & LF); + Put (S, "function K (N : Node_Id) return Node_Kind renames " & Image (Nkind) & ";" & LF); Put (S, "-- Shorthand for use in predicates and preconditions below" & LF); Put (S, "-- There is no procedure Set_Nkind." & LF); Put (S, "-- See Init_Nkind and Mutate_Nkind in Atree." & LF & LF); @@ -1587,66 +1411,26 @@ package body Gen_IL.Gen is Put (S, LF & "subtype Flag is Boolean;" & LF & LF); end Put_Type_And_Subtypes; - function Low_Level_Getter_Name (T : Type_Enum) return String is - ("Get_" & Image (T)); - function Low_Level_Setter_Name (T : Type_Enum) return String is - ("Set_" & Image (T)); - function Low_Level_Setter_Name (F : Field_Enum) return String is - (Low_Level_Setter_Name (Field_Table (F).Field_Type) & - (if Setter_Needs_Parent (F) then "_With_Parent" else "")); - ------------------------------------------- - -- Put_Low_Level_Accessor_Instantiations -- + -- Put_Casts -- ------------------------------------------- - procedure Put_Low_Level_Accessor_Instantiations + procedure Put_Casts (S : in out Sink; T : Type_Enum) is + Pre : constant String := + "function Cast is new Unchecked_Conversion ("; + Lo_Type : constant String := "Field_Size_" & Image (Field_Size (T)) & "_Bit"; + Hi_Type : constant String := Get_Set_Id_Image (T); begin - -- Special case for subtypes of Uint that have predicates. Use - -- Get_Valid_32_Bit_Field in that case. - - if T in Uint_Subtype then - pragma Assert (Field_Size (T) = 32); - Put (S, LF & "function " & Low_Level_Getter_Name (T) & - " is new Get_Valid_32_Bit_Field (" & - Get_Set_Id_Image (T) & - ") with " & Inline & ";" & LF); - - -- Special case for types that have special defaults; instantiate - -- Get_32_Bit_Field_With_Default and pass in the Default_Val. - - elsif Field_Has_Special_Default (T) then - pragma Assert (Field_Size (T) = 32); - Put (S, LF & "function " & Low_Level_Getter_Name (T) & - " is new Get_32_Bit_Field_With_Default (" & - Get_Set_Id_Image (T) & ", " & Special_Default (T) & - ") with " & Inline & ";" & LF); - - -- Otherwise, instantiate the normal getter for the right size in - -- bits. - - else - Put (S, LF & "function " & Low_Level_Getter_Name (T) & - " is new Get_" & Image (Field_Size (T)) & "_Bit_Field (" & - Get_Set_Id_Image (T) & ") with " & Inline & ";" & LF); - end if; - - if T in Node_Kind_Type | Entity_Kind_Type then - Put (S, "pragma Warnings (Off);" & LF); - -- Set_Node_Kind_Type and Set_Entity_Kind_Type might not be called - end if; - - -- No special cases for the setter - - Put (S, "procedure " & Low_Level_Setter_Name (T) & " is new Set_" & - Image (Field_Size (T)) & "_Bit_Field (" & Get_Set_Id_Image (T) & - ") with " & Inline & ";" & LF); + if T not in Uint_Subtype then + if T not in Node_Kind_Type | Entity_Kind_Type then + Put (S, Pre & Hi_Type & ", " & Lo_Type & ");" & LF); + end if; - if T in Node_Kind_Type | Entity_Kind_Type then - Put (S, "pragma Warnings (On);" & LF); + Put (S, Pre & Lo_Type & ", " & Hi_Type & ");" & LF); end if; - end Put_Low_Level_Accessor_Instantiations; + end Put_Casts; ---------------------- -- Put_Precondition -- @@ -1713,6 +1497,25 @@ package body Gen_IL.Gen is -- Node_Id or Entity_Id, and the getter and setter will have -- preconditions. + procedure Put_Get_Set_Incr + (S : in out Sink; F : Field_Enum; Get_Or_Set : String) + with Pre => Get_Or_Set in "Get" | "Set"; + -- If statistics are enabled, put the appropriate increment statement + + ---------------------- + -- Put_Get_Set_Incr -- + ---------------------- + + procedure Put_Get_Set_Incr + (S : in out Sink; F : Field_Enum; Get_Or_Set : String) is + begin + if Statistics_Enabled then + Put (S, "Atree." & Get_Or_Set & "_Count (" & F_Image (F) & + ") := Atree." & Get_Or_Set & "_Count (" & + F_Image (F) & ") + 1;" & LF); + end if; + end Put_Get_Set_Incr; + ------------------------ -- Node_To_Fetch_From -- ------------------------ @@ -1748,17 +1551,68 @@ package body Gen_IL.Gen is Put (S, " with " & Inline); Increase_Indent (S, 2); Put_Precondition (S, F); - Decrease_Indent (S, 2); Put (S, ";" & LF); end Put_Getter_Decl; + ------------------------------ + -- Put_Getter_Setter_Locals -- + ------------------------------ + + procedure Put_Getter_Setter_Locals + (S : in out Sink; F : Field_Enum; Get : Boolean) + is + Rec : Field_Info renames Field_Table (F).all; + + F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type); + Off : constant Field_Offset := Rec.Offset; + F_Per_Slot : constant Field_Offset := + SS / Field_Offset (Field_Size (Rec.Field_Type)); + Slot_Off : constant Field_Offset := Off / F_Per_Slot; + In_NH : constant Boolean := Slot_Off < Num_Header_Slots; + + N : constant String := + (if Get then Node_To_Fetch_From (F) else "N"); + + begin + Put (S, " is" & LF); + Increase_Indent (S, 3); + Put (S, "-- " & Image (F_Per_Slot) & " " & Image (F_Size) & + "-bit fields per " & SSS & "-bit slot." & LF); + Put (S, "-- Offset " & Image (Off) & " = " & + Image (Slot_Off) & " slots + " & Image (Off mod F_Per_Slot) & + " fields in slot." & LF & LF); + + Put (S, "Off : constant := " & Image (Off) & ";" & LF); + Put (S, "F_Size : constant := " & Image (F_Size) & ";" & LF); + + if Field_Size (Rec.Field_Type) /= SS then + Put (S, "Mask : constant := 2**F_Size - 1;" & LF); + end if; + + Put (S, "F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;" & LF); + Put (S, "Slot_Off : constant Field_Offset := Off / F_Per_Slot;" & LF); + + if In_NH then + Put (S, "S : Slot renames Node_Offsets.Table (" & N & ").Slots (Slot_Off);" & LF); + else + Put (S, "S : Slot renames Slots.Table (Node_Offsets.Table (" & N & ").Offset + Slot_Off);" & LF); + end if; + + if Field_Size (Rec.Field_Type) /= SS then + Put (S, "V : constant Natural := Natural ((Off mod F_Per_Slot) * F_Size);" & LF); + Put (S, LF); + end if; + end Put_Getter_Setter_Locals; + --------------------- -- Put_Getter_Body -- --------------------- procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is Rec : Field_Info renames Field_Table (F).all; + F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type); + T : constant String := Get_Set_Id_Image (Rec.Field_Type); begin -- Note that we store the result in a local constant below, so that -- the "Pre => ..." can refer to it. The constant is called Val so @@ -1767,16 +1621,44 @@ package body Gen_IL.Gen is -- and setter. Put_Getter_Spec (S, F); - Put (S, " is" & LF); - Increase_Indent (S, 3); - Put (S, "Val : constant " & Get_Set_Id_Image (Rec.Field_Type) & - " := " & Low_Level_Getter_Name (Rec.Field_Type) & - " (" & Node_To_Fetch_From (F) & ", " & - Image (Rec.Offset) & ");" & LF); + Put_Getter_Setter_Locals (S, F, Get => True); + + Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit :=" & LF); + Increase_Indent (S, 2); + Put (S, "Field_Size_" & Image (F_Size) & "_Bit ("); + + if Field_Size (Rec.Field_Type) /= SS then + Put (S, "Shift_Right (S, V) and Mask);" & LF); + else + Put (S, "S);" & LF); + end if; + + Decrease_Indent (S, 2); + + Put (S, "Val : constant " & T & " :="); + + if Field_Has_Special_Default (Rec.Field_Type) then + pragma Assert (Field_Size (Rec.Field_Type) = 32); + Put (S, LF); + Increase_Indent (S, 2); + Put (S, "(if Raw = 0 then " & Special_Default (Rec.Field_Type) & + " else " & "Cast (Raw));"); + Decrease_Indent (S, 2); + + else + Put (S, " Cast (Raw);"); + end if; + + Put (S, LF); + Decrease_Indent (S, 3); Put (S, "begin" & LF); Increase_Indent (S, 3); + Put (S, "-- pragma Debug (Validate_Node_And_Offset (NN, Slot_Off));" & LF); + -- Comment out the validation, because it's too slow, and because the + -- relevant routines in Atree are not visible. + if Rec.Pre.all /= "" then Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF); end if; @@ -1785,6 +1667,7 @@ package body Gen_IL.Gen is Put (S, "pragma Assert (" & Rec.Pre_Get.all & ");" & LF); end if; + Put_Get_Set_Incr (S, F, "Get"); Put (S, "return Val;" & LF); Decrease_Indent (S, 3); Put (S, "end " & Image (F) & ";" & LF & LF); @@ -1824,6 +1707,7 @@ package body Gen_IL.Gen is procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is Rec : Field_Info renames Field_Table (F).all; + F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type); -- If Type_Only was specified in the call to Create_Semantic_Field, -- then we assert that the node is a base type. We cannot assert that @@ -1836,10 +1720,18 @@ package body Gen_IL.Gen is "Is_Base_Type (N)"); begin Put_Setter_Spec (S, F); - Put (S, " is" & LF); + Put_Getter_Setter_Locals (S, F, Get => False); + + Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit := Cast (Val);" & LF); + + Decrease_Indent (S, 3); Put (S, "begin" & LF); Increase_Indent (S, 3); + Put (S, "-- pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));" & LF); + -- Comment out the validation, because it's too slow, and because the + -- relevant routines in Atree are not visible. + if Rec.Pre.all /= "" then Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF); end if; @@ -1852,8 +1744,29 @@ package body Gen_IL.Gen is Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF); end if; - Put (S, Low_Level_Setter_Name (F) & " (N, " & Image (Rec.Offset) - & ", Val);" & LF); + if Setter_Needs_Parent (F) then + declare + Err : constant String := + (if Rec.Field_Type = List_Id then "Error_List" else "Error"); + begin + Put (S, "if Present (Val) and then Val /= " & Err & " then" & LF); + Increase_Indent (S, 3); + Put (S, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF); + Put (S, "Set_Parent (Val, N);" & LF); + Put (S, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF); + Decrease_Indent (S, 3); + Put (S, "end if;" & LF & LF); + end; + end if; + + if Field_Size (Rec.Field_Type) /= SS then + Put (S, "S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Raw), V);" & LF); + + else + Put (S, "S := Slot (Raw);" & LF); + end if; + + Put_Get_Set_Incr (S, F, "Set"); Decrease_Indent (S, 3); Put (S, "end Set_" & Image (F) & ";" & LF & LF); end Put_Setter_Body; @@ -2076,7 +1989,7 @@ package body Gen_IL.Gen is when others => "Entity_Field"); -- Entity_Kind begin - Put (S, "-- Table of sizes in 32-bit slots for given " & + Put (S, "-- Table of sizes in " & SSS & "-bit slots for given " & Image (Root) & ", for use by Atree:" & LF); case Root is @@ -2085,8 +1998,7 @@ package body Gen_IL.Gen is Image (Min_Node_Size) & ";" & LF); Put (S, "Max_Node_Size : constant Field_Offset := " & Image (Max_Node_Size) & ";" & LF & LF); - Put (S, "Average_Node_Size_In_Slots : constant := " & - Average_Node_Size_In_Slots'Img & ";" & LF & LF); + when Entity_Kind => Put (S, LF & "Min_Entity_Size : constant Field_Offset := " & Image (Min_Entity_Size) & ";" & LF); @@ -2107,34 +2019,48 @@ package body Gen_IL.Gen is Put (S, "); -- Size" & LF); Decrease_Indent (S, 2); - declare - type Dummy is array - (First_Field (Root) .. Last_Field (Root)) of Boolean; - Num_Fields : constant Root_Int := Dummy'Length; - First_Time : Boolean := True; - begin - Put (S, LF & "-- Enumeration of all " & Image (Num_Fields) - & " fields:" & LF & LF); + if Root = Node_Kind then + declare + type Node_Dummy is array (Node_Field) of Boolean; + type Entity_Dummy is array (Entity_Field) of Boolean; + Num_Fields : constant Root_Int := + Node_Dummy'Length + Entity_Dummy'Length; + First_Time : Boolean := True; + begin + Put (S, LF & "-- Enumeration of all " & Image (Num_Fields) + & " fields:" & LF & LF); - Put (S, "type " & Field_Enum_Type_Name & " is" & LF); - Increase_Indent (S, 2); - Put (S, "("); - Increase_Indent (S, 1); + Put (S, "type Node_Or_Entity_Field is" & LF); + Increase_Indent (S, 2); + Put (S, "("); + Increase_Indent (S, 1); - for F in First_Field (Root) .. Last_Field (Root) loop - if First_Time then - First_Time := False; - else + for F in Node_Field loop + if First_Time then + First_Time := False; + else + Put (S, "," & LF); + end if; + + Put (S, F_Image (F)); + end loop; + + for F in Entity_Field loop Put (S, "," & LF); - end if; + Put (S, F_Image (F)); + end loop; - Put (S, F_Image (F)); - end loop; + Decrease_Indent (S, 1); + Put (S, "); -- Node_Or_Entity_Field" & LF); + Decrease_Indent (S, 2); + end; + end if; - Decrease_Indent (S, 1); - Put (S, "); -- " & Field_Enum_Type_Name & LF); - Decrease_Indent (S, 2); - end; + Put (S, LF & "subtype " & Field_Enum_Type_Name & " is" & LF); + Increase_Indent (S, 2); + Put (S, "Node_Or_Entity_Field range " & F_Image (First_Field (Root)) & + " .. " & F_Image (Last_Field (Root)) & ";" & LF); + Decrease_Indent (S, 2); Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF); Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" & @@ -2193,34 +2119,67 @@ package body Gen_IL.Gen is Decrease_Indent (S, 2); end; - declare - First_Time : Boolean := True; - begin - Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF); + if Root = Node_Kind then + declare + First_Time : Boolean := True; + FS, FB, LB : Bit_Offset; + -- Field size in bits, first bit, and last bit for the previous + -- time around the loop. Used to print a comment after ",". - Put (S, Field_Enum_Type_Name & "_Descriptors : constant array (" & - Field_Enum_Type_Name & ") of Field_Descriptor :=" & LF); + procedure One_Comp (F : Field_Enum); - Increase_Indent (S, 2); - Put (S, "("); - Increase_Indent (S, 1); + procedure One_Comp (F : Field_Enum) is + pragma Annotate (Codepeer, Modified, Field_Table); + Offset : constant Field_Offset := Field_Table (F).Offset; + begin + if First_Time then + First_Time := False; + else + Put (S, ","); - for F in First_Field (Root) .. Last_Field (Root) loop - if First_Time then - First_Time := False; - else - Put (S, "," & LF); - end if; + -- Print comment showing field's bits, except for 1-bit + -- fields. - Put (S, F_Image (F) & " => (" & - Image (Field_Table (F).Field_Type) & "_Field, " & - Image (Field_Table (F).Offset) & ")"); - end loop; + if FS /= 1 then + Put (S, " -- *" & Image (FS) & " = bits " & + Image (FB) & ".." & Image (LB)); + end if; - Decrease_Indent (S, 1); - Put (S, "); -- Field_Descriptors" & LF); - Decrease_Indent (S, 2); - end; + Put (S, LF); + end if; + + Put (S, F_Image (F) & " => (" & + Image (Field_Table (F).Field_Type) & "_Field, " & + Image (Offset) & ")"); + + FS := Field_Size (F); + FB := First_Bit (F, Offset); + LB := Last_Bit (F, Offset); + end One_Comp; + + begin + Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF); + + Put (S, "Field_Descriptors : constant array (" & + "Node_Or_Entity_Field) of Field_Descriptor :=" & LF); + + Increase_Indent (S, 2); + Put (S, "("); + Increase_Indent (S, 1); + + for F in Node_Field loop + One_Comp (F); + end loop; + + for F in Entity_Field loop + One_Comp (F); + end loop; + + Decrease_Indent (S, 1); + Put (S, "); -- Field_Descriptors" & LF); + Decrease_Indent (S, 2); + end; + end if; end Put_Tables; @@ -2291,7 +2250,16 @@ package body Gen_IL.Gen is Put (S, "Kind : Field_Kind;" & LF); Put (S, "Offset : Field_Offset;" & LF); Decrease_Indent (S, 3); - Put (S, "end record;" & LF); + Put (S, "end record;" & LF & LF); + + -- Print out the node header types. Note that the Offset field is of + -- the base type, because we are using zero-origin addressing in + -- Atree. + + Put (S, "N_Head : constant Field_Offset := " & N_Head & ";" & LF & LF); + + Put (S, "Atree_Statistics_Enabled : constant Boolean := " & + Capitalize (Boolean'Image (Statistics_Enabled)) & ";" & LF); Decrease_Indent (S, 3); Put (S, LF & "end Seinfo;" & LF); @@ -2305,39 +2273,6 @@ package body Gen_IL.Gen is S : Sink; B : Sink; - procedure Put_Setter_With_Parent (Kind : String); - -- Put the low-level ..._With_Parent setter. Kind is either "Node" or - -- "List". - - procedure Put_Setter_With_Parent (Kind : String) is - Error : constant String := (if Kind = "Node" then "" else "_" & Kind); - begin - Put (B, LF & "procedure Set_" & Kind & "_Id_With_Parent" & LF); - Increase_Indent (B, 2); - Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id);" & LF & LF); - Decrease_Indent (B, 2); - - Put (B, "procedure Set_" & Kind & "_Id_With_Parent" & LF); - Increase_Indent (B, 2); - Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id) is" & LF); - Decrease_Indent (B, 2); - Put (B, "begin" & LF); - Increase_Indent (B, 3); - Put (B, "if Present (Val) and then Val /= Error" & Error & " then" & LF); - Increase_Indent (B, 3); - Put (B, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF); - Put (B, "Set_Parent (Val, N);" & LF); - Put (B, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF); - Decrease_Indent (B, 3); - Put (B, "end if;" & LF & LF); - - Put (B, "Set_" & Kind & "_Id (N, Offset, Val);" & LF); - Decrease_Indent (B, 3); - Put (B, "end Set_" & Kind & "_Id_With_Parent;" & LF); - end Put_Setter_With_Parent; - - -- Start of processing for Put_Nodes - begin Create_File (S, "sinfo-nodes.ads"); Create_File (B, "sinfo-nodes.adb"); @@ -2369,6 +2304,7 @@ package body Gen_IL.Gen is Decrease_Indent (S, 3); Put (S, LF & "end Sinfo.Nodes;" & LF); + Put (B, "with Unchecked_Conversion;" & LF); Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF); Put (B, "with Nlists; use Nlists;" & LF); Put (B, "pragma Warnings (Off);" & LF); @@ -2381,19 +2317,14 @@ package body Gen_IL.Gen is Put (B, "-- This package is automatically generated." & LF & LF); - Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF); - Put (B, "-- in units of the size of the field." & LF); - Put (B, "pragma Style_Checks (""M200"");" & LF); + for T in Special_Type loop if Node_Field_Types_Used (T) then - Put_Low_Level_Accessor_Instantiations (B, T); + Put_Casts (B, T); end if; end loop; - Put_Setter_With_Parent ("Node"); - Put_Setter_With_Parent ("List"); - Put_Subp_Bodies (B, Node_Kind); Decrease_Indent (B, 3); @@ -2411,7 +2342,6 @@ package body Gen_IL.Gen is begin Create_File (S, "einfo-entities.ads"); Create_File (B, "einfo-entities.adb"); - Put (S, "with Seinfo; use Seinfo;" & LF); Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF); Put (S, LF & "package Einfo.Entities is" & LF & LF); @@ -2430,6 +2360,7 @@ package body Gen_IL.Gen is Decrease_Indent (S, 3); Put (S, LF & "end Einfo.Entities;" & LF); + Put (B, "with Unchecked_Conversion;" & LF); Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF); Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF); -- This forms a cycle between packages (via bodies, which is OK) @@ -2439,13 +2370,11 @@ package body Gen_IL.Gen is Put (B, "-- This package is automatically generated." & LF & LF); - Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF); - Put (B, "-- in units of the size of the field." & LF); - Put (B, "pragma Style_Checks (""M200"");" & LF); + for T in Special_Type loop if Entity_Field_Types_Used (T) then - Put_Low_Level_Accessor_Instantiations (B, T); + Put_Casts (B, T); end if; end loop; @@ -2494,7 +2423,8 @@ package body Gen_IL.Gen is end if; end loop; - Put (S, ")" & LF & "return " & Node_Or_Entity (Root) & "_Id"); + Put (S, ")" & LF); + Put (S, "return " & Node_Or_Entity (Root) & "_Id"); Decrease_Indent (S, 2); Decrease_Indent (S, 1); end Put_Make_Spec; @@ -2714,11 +2644,11 @@ package body Gen_IL.Gen is return Result : Bit_Offset do if F = No_Field then -- We don't have a field size for No_Field, so just look at - -- the bits up to the next word boundary. + -- the bits up to the next slot boundary. Result := First_Bit; - while (Result + 1) mod 32 /= 0 + while (Result + 1) mod SS /= 0 and then Type_Layout (T) (Result + 1) = No_Field loop Result := Result + 1; @@ -2731,19 +2661,19 @@ package body Gen_IL.Gen is end Get_Last_Bit; function First_Bit_Image (First_Bit : Bit_Offset) return String is - W : constant Bit_Offset := First_Bit / 32; - B : constant Bit_Offset := First_Bit mod 32; - pragma Assert (W * 32 + B = First_Bit); + W : constant Bit_Offset := First_Bit / SS; + B : constant Bit_Offset := First_Bit mod SS; + pragma Assert (W * SS + B = First_Bit); begin return - Image (W) & "*32" & (if B = 0 then "" else " + " & Image (B)); + Image (W) & "*" & SSS & (if B = 0 then "" else " + " & Image (B)); end First_Bit_Image; function Last_Bit_Image (Last_Bit : Bit_Offset) return String is - W : constant Bit_Offset := (Last_Bit + 1) / 32; + W : constant Bit_Offset := (Last_Bit + 1) / SS; begin - if W * 32 - 1 = Last_Bit then - return Image (W) & "*32 - 1"; + if W * SS - 1 = Last_Bit then + return Image (W) & "*" & SSS & " - 1"; else return First_Bit_Image (Last_Bit); end if; @@ -2857,6 +2787,7 @@ package body Gen_IL.Gen is declare First_Time : Boolean := True; + begin for T in Concrete_Type loop if First_Time then @@ -2878,40 +2809,45 @@ package body Gen_IL.Gen is declare First_Time : Boolean := True; First_Bit : Bit_Offset := 0; + F : Opt_Field_Enum; + + function Node_Field_Of_Entity return String is + (if T in Entity_Type and then F in Node_Field then + " -- N" else ""); + -- A comment to put out for fields of entities that are + -- shared with nodes, such as Chars. + begin while First_Bit < Type_Bit_Size_Aligned (T) loop if First_Time then First_Time := False; else - Put (B, "," & LF); + Put (B, "," & Node_Field_Of_Entity & LF); end if; + F := Type_Layout (T) (First_Bit); + declare - F : constant Opt_Field_Enum := - Type_Layout (T) (First_Bit); + Last_Bit : constant Bit_Offset := + Get_Last_Bit (T, F, First_Bit); begin - declare - Last_Bit : constant Bit_Offset := - Get_Last_Bit (T, F, First_Bit); - begin + pragma Assert + (Type_Layout (T) (First_Bit .. Last_Bit) = + (First_Bit .. Last_Bit => F)); + + if Last_Bit = First_Bit then + Put (B, First_Bit_Image (First_Bit) & " => " & + Image_Or_Waste (F)); + else pragma Assert - (Type_Layout (T) (First_Bit .. Last_Bit) = - (First_Bit .. Last_Bit => F)); - - if Last_Bit = First_Bit then - Put (B, First_Bit_Image (First_Bit) & " => " & - Image_Or_Waste (F)); - else - pragma Assert - (if F /= No_Field then - First_Bit mod Field_Size (F) = 0); - Put (B, First_Bit_Image (First_Bit) & " .. " & - Last_Bit_Image (Last_Bit) & " => " & - Image_Or_Waste (F)); - end if; - - First_Bit := Last_Bit + 1; - end; + (if F /= No_Field then + First_Bit mod Field_Size (F) = 0); + Put (B, First_Bit_Image (First_Bit) & " .. " & + Last_Bit_Image (Last_Bit) & " => " & + Image_Or_Waste (F)); + end if; + + First_Bit := Last_Bit + 1; end; end loop; end; @@ -3017,6 +2953,8 @@ package body Gen_IL.Gen is end Put_Kind_Subtype; begin + Put_Union_Membership (S, Root, Only_Prototypes => True); + Iterate_Types (Root, Pre => Put_Enum_Lit'Access); Put (S, "#define Number_" & Node_Or_Entity (Root) & "_Kinds " & @@ -3024,86 +2962,94 @@ package body Gen_IL.Gen is Iterate_Types (Root, Pre => Put_Kind_Subtype'Access); - Put_Union_Membership (S, Root); + Put_Union_Membership (S, Root, Only_Prototypes => False); end Put_C_Type_And_Subtypes; - ---------------------------- - -- Put_Low_Level_C_Getter -- - ---------------------------- + ------------------ + -- Put_C_Getter -- + ------------------ - procedure Put_Low_Level_C_Getter - (S : in out Sink; T : Type_Enum) + procedure Put_C_Getter + (S : in out Sink; F : Field_Enum) is - T_Image : constant String := Get_Set_Id_Image (T); + Rec : Field_Info renames Field_Table (F).all; + Off : constant Field_Offset := Rec.Offset; + F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type); + F_Per_Slot : constant Field_Offset := + SS / Field_Offset (Field_Size (Rec.Field_Type)); + Slot_Off : constant Field_Offset := Off / F_Per_Slot; + In_NH : constant Boolean := Slot_Off < Num_Header_Slots; + + N : constant String := Node_To_Fetch_From (F); begin - Put (S, "INLINE " & T_Image & "" & LF); - Put (S, "Get_" & Image (T) & " (Node_Id N, Field_Offset Offset)" & LF); + Put (S, "INLINE " & Get_Set_Id_Image (Rec.Field_Type) & + " " & Image (F) & " (Node_Id N)" & LF); + Put (S, "{" & LF); Increase_Indent (S, 3); + Put (S, "const Field_Offset Off = " & Image (Rec.Offset) & ";" & LF); + Put (S, "const Field_Offset F_Size = " & Image (F_Size) & ";" & LF); - -- Same special cases for getters as in - -- Put_Low_Level_Accessor_Instantiations. - - if T in Uint_Subtype then - pragma Assert (Field_Size (T) = 32); - Put (S, "{ return (" & T_Image & - ") Get_Valid_32_Bit_Field(N, Offset); }" & LF & LF); + if Field_Size (Rec.Field_Type) /= SS then + Put (S, "const any_slot Mask = (1 << F_Size) - 1;" & LF); + end if; - elsif Field_Has_Special_Default (T) then - pragma Assert (Field_Size (T) = 32); - Put (S, "{ return (" & T_Image & - ") Get_32_Bit_Field_With_Default(N, Offset, " & - Special_Default (T) & "); }" & LF & LF); + Put (S, "const Field_Offset F_Per_Slot = Slot_Size / F_Size;" & LF); + Put (S, "const Field_Offset Slot_Off = Off / F_Per_Slot;" & LF); + Put (S, LF); + if In_NH then + Put (S, "any_slot slot = Node_Offsets_Ptr[" & N & "].Slots[Slot_Off];" & LF); + else + Put (S, "any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[" & N & + "].Offset + Slot_Off);" & LF); + end if; + if Field_Size (Rec.Field_Type) /= SS then + Put (S, "unsigned int Raw = (slot >> (Off % F_Per_Slot) * F_Size) & Mask;" & LF); else - Put (S, "{ return (" & T_Image & ") Get_" & - Image (Field_Size (T)) & "_Bit_Field(N, Offset); }" & LF & LF); + Put (S, "unsigned int Raw = slot;" & LF); end if; - Decrease_Indent (S, 3); - end Put_Low_Level_C_Getter; + Put (S, Get_Set_Id_Image (Rec.Field_Type) & " val = "); - ----------------------------- - -- Put_High_Level_C_Getter -- - ----------------------------- + if Field_Has_Special_Default (Rec.Field_Type) then + Increase_Indent (S, 2); + Put (S, "(Raw? Raw : " & Special_Default (Rec.Field_Type) & ")"); + Decrease_Indent (S, 2); - procedure Put_High_Level_C_Getter - (S : in out Sink; F : Field_Enum) - is - begin - Put (S, "INLINE " & Get_Set_Id_Image (Field_Table (F).Field_Type) & - " " & Image (F) & " (Node_Id N)" & LF); + else + Put (S, "Raw"); + end if; - Increase_Indent (S, 3); - Put (S, "{ return " & - Low_Level_Getter_Name (Field_Table (F).Field_Type) & - "(" & Node_To_Fetch_From (F) & ", " & - Image (Field_Table (F).Offset) & "); }" & LF & LF); + Put (S, ";" & LF); + + Put (S, "return val;" & LF); Decrease_Indent (S, 3); - end Put_High_Level_C_Getter; + Put (S, "}" & LF & LF); + end Put_C_Getter; - ------------------------------ - -- Put_High_Level_C_Getters -- - ------------------------------ + ------------------- + -- Put_C_Getters -- + ------------------- - procedure Put_High_Level_C_Getters + procedure Put_C_Getters (S : in out Sink; Root : Root_Type) is begin Put (S, "// Getters for fields" & LF & LF); for F in First_Field (Root) .. Last_Field (Root) loop - Put_High_Level_C_Getter (S, F); + Put_C_Getter (S, F); end loop; - end Put_High_Level_C_Getters; + end Put_C_Getters; -------------------------- -- Put_Union_Membership -- -------------------------- procedure Put_Union_Membership - (S : in out Sink; Root : Root_Type) is + (S : in out Sink; Root : Root_Type; Only_Prototypes : Boolean) is procedure Put_Ors (T : Abstract_Type); -- Print the "or" (i.e. "||") of tests whether kind is in each child @@ -3137,22 +3083,27 @@ package body Gen_IL.Gen is end Put_Ors; begin - Put (S, LF & "// Membership tests for union types" & LF & LF); + if not Only_Prototypes then + Put (S, LF & "// Membership tests for union types" & LF & LF); + end if; for T in First_Abstract (Root) .. Last_Abstract (Root) loop if Type_Table (T) /= null and then Type_Table (T).Is_Union then Put (S, "INLINE Boolean" & LF); Put (S, "Is_In_" & Image (T) & " (" & - Node_Or_Entity (Root) & "_Kind kind)" & LF); + Node_Or_Entity (Root) & "_Kind kind)" & + (if Only_Prototypes then ";" else "") & LF); - Put (S, "{" & LF); - Increase_Indent (S, 3); - Put (S, "return" & LF); - Increase_Indent (S, 3); - Put_Ors (T); - Decrease_Indent (S, 3); - Decrease_Indent (S, 3); - Put (S, ";" & LF & "}" & LF); + if not Only_Prototypes then + Put (S, "{" & LF); + Increase_Indent (S, 3); + Put (S, "return" & LF); + Increase_Indent (S, 3); + Put_Ors (T); + Decrease_Indent (S, 3); + Decrease_Indent (S, 3); + Put (S, ";" & LF & "}" & LF); + end if; Put (S, "" & LF); end if; @@ -3174,16 +3125,24 @@ package body Gen_IL.Gen is Put (S, "typedef Boolean Flag;" & LF & LF); + Put (S, "#define N_Head " & N_Head & LF); + Put (S, "" & LF); + Put (S, "typedef struct Node_Header {" & LF); + Increase_Indent (S, 2); + Put (S, "any_slot Slots[N_Head];" & LF); + Put (S, "Field_Offset Offset;" & LF); + Decrease_Indent (S, 2); + Put (S, "} Node_Header;" & LF & LF); + + Put (S, "extern Node_Header *Node_Offsets_Ptr;" & LF); + Put (S, "extern any_slot *Slots_Ptr;" & LF & LF); + Put_C_Type_And_Subtypes (S, Node_Kind); Put (S, "// Getters corresponding to instantiations of Atree.Get_n_Bit_Field" & LF & LF); - for T in Special_Type loop - Put_Low_Level_C_Getter (S, T); - end loop; - - Put_High_Level_C_Getters (S, Node_Kind); + Put_C_Getters (S, Node_Kind); Put (S, "#ifdef __cplusplus" & LF); Put (S, "}" & LF); @@ -3238,11 +3197,7 @@ package body Gen_IL.Gen is Put_C_Type_And_Subtypes (S, Entity_Kind); - -- Note that we do not call Put_Low_Level_C_Getter here. Those are in - -- sinfo.h, so every file that #includes einfo.h must #include - -- sinfo.h first. - - Put_High_Level_C_Getters (S, Entity_Kind); + Put_C_Getters (S, Entity_Kind); Put (S, "// Abstract type queries" & LF & LF); diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index d77fe7a..fe1af78 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -255,7 +255,7 @@ package body Gen_IL.Internals is begin case F is -- Special cases for the same reason as in the above Image - -- function. + -- function for Opt_Type_Enum. when Alloc_For_BIP_Return => return "Alloc_For_BIP_Return"; diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads index 53c23a2..a811e0b4 100644 --- a/gcc/ada/gen_il-internals.ads +++ b/gcc/ada/gen_il-internals.ads @@ -147,6 +147,9 @@ package Gen_IL.Internals is -- The default is No_Type_Only, indicating the field is not one of -- these special "[... only]" ones. + Unknown_Offset : constant := -1; + -- Initial value of Offset, so we can tell whether it has been set + type Field_Info is record Have_This_Field : Type_Vector; -- Types that have this field @@ -162,7 +165,7 @@ package Gen_IL.Internals is -- Above record the information in the calls to Create_...Field. -- See Gen_IL.Gen for details. - Offset : Field_Offset; + Offset : Field_Offset'Base range Unknown_Offset .. Field_Offset'Last; -- Offset of the field from the start of the node, in units of the field -- size. So if a field is 4 bits in size, it starts at bit number -- Offset*4 from the start of the node. @@ -274,4 +277,344 @@ package Gen_IL.Internals is -- Return "Node" or "Entity" depending on whether Root = Node_Kind or -- Entity_Kind. + pragma Style_Checks (Off); + -- We don't want warnings about wrong casing in the Type_Frequency table; + -- this table is not intended to be particularly readable. + + -- The Type_Frequency table shows the frequency of nodes and entity kinds + -- printed by -gnatd.A for a large example. It is used in the field offset + -- computations for efficiency. Note that N_Defining_Identifier, + -- N_Defining_Operator_Symbol, and N_Defining_Character_Literal are set to + -- zero, because the Ekind is what matters for those. + + Type_Frequency : constant array (Concrete_Type) of Type_Count := + (N_Identifier => 3496964, -- (0.354) 7 slots + N_Defining_Identifier => 0, -- 1468484, -- (0.149) 8 slots + N_Integer_Literal => 455415, -- (0.046) 6 slots + E_In_Parameter => 391008, -- (0.040) 42 slots + N_Attribute_Reference => 330825, -- (0.033) 9 slots + N_Expanded_Name => 329509, -- (0.033) 8 slots + N_Selected_Component => 328862, -- (0.033) 8 slots + N_Parameter_Specification => 321313, -- (0.033) 7 slots + E_Void => 173019, -- (0.018) 59 slots + N_Explicit_Dereference => 155113, -- (0.016) 8 slots + N_Procedure_Call_Statement => 125403, -- (0.013) 8 slots + N_Object_Declaration => 115610, -- (0.012) 8 slots + E_Component => 108208, -- (0.011) 49 slots + N_Procedure_Specification => 106277, -- (0.011) 7 slots + E_Procedure => 104063, -- (0.011) 62 slots + N_Unchecked_Type_Conversion => 94477, -- (0.010) 7 slots + N_Range => 91413, -- (0.009) 6 slots + E_Function => 90035, -- (0.009) 62 slots + N_Handled_Sequence_Of_Statements => 87930, -- (0.009) 8 slots + N_Subprogram_Declaration => 85248, -- (0.009) 7 slots + N_Parameter_Association => 81464, -- (0.008) 8 slots + N_Indexed_Component => 80049, -- (0.008) 7 slots + N_Freeze_Entity => 79904, -- (0.008) 8 slots + N_Call_Marker => 79521, -- (0.008) 4 slots + N_Assignment_Statement => 76554, -- (0.008) 8 slots + N_Function_Specification => 76052, -- (0.008) 7 slots + N_Function_Call => 75028, -- (0.008) 9 slots + N_Op_Eq => 74874, -- (0.008) 8 slots + E_Constant => 66667, -- (0.007) 47 slots + N_If_Statement => 60066, -- (0.006) 8 slots + N_Component_Association => 54642, -- (0.006) 7 slots + N_Subprogram_Body => 53805, -- (0.005) 10 slots + N_Type_Conversion => 53383, -- (0.005) 7 slots + E_In_Out_Parameter => 52936, -- (0.005) 38 slots + N_Simple_Return_Statement => 52436, -- (0.005) 7 slots + N_Subtype_Indication => 49535, -- (0.005) 6 slots + N_Raise_Constraint_Error => 49069, -- (0.005) 6 slots + N_Null => 46850, -- (0.005) 5 slots + N_Itype_Reference => 45422, -- (0.005) 4 slots + E_Anonymous_Access_Type => 45149, -- (0.005) 44 slots + N_And_Then => 44721, -- (0.005) 8 slots + N_Block_Statement => 44328, -- (0.004) 10 slots + N_Subtype_Declaration => 43149, -- (0.004) 6 slots + N_Op_Not => 40531, -- (0.004) 7 slots + E_Array_Subtype => 40051, -- (0.004) 50 slots + N_Expression_With_Actions => 36726, -- (0.004) 7 slots + E_Access_Subprogram_Type => 36700, -- (0.004) 45 slots + E_Signed_Integer_Subtype => 36659, -- (0.004) 43 slots + N_String_Literal => 34815, -- (0.004) 7 slots + N_Aggregate => 33899, -- (0.003) 8 slots + N_Index_Or_Discriminant_Constraint => 33546, -- (0.003) 4 slots + E_Variable => 33102, -- (0.003) 55 slots + E_Block => 32829, -- (0.003) 58 slots + N_Op_Ne => 32127, -- (0.003) 8 slots + N_Pragma_Argument_Association => 31504, -- (0.003) 7 slots + N_Null_Statement => 30816, -- (0.003) 5 slots + N_Aspect_Specification => 29667, -- (0.003) 9 slots + N_Pragma => 28317, -- (0.003) 9 slots + N_Generic_Association => 26297, -- (0.003) 8 slots + N_Formal_Concrete_Subprogram_Declaration => 25843, -- (0.003) 6 slots + N_Op_Lt => 25328, -- (0.003) 8 slots + E_String_Literal_Subtype => 25272, -- (0.003) 48 slots + N_Full_Type_Declaration => 25258, -- (0.003) 7 slots + N_With_Clause => 24370, -- (0.002) 9 slots + N_Op_Add => 23839, -- (0.002) 8 slots + E_Subprogram_Body => 23790, -- (0.002) 42 slots + E_Return_Statement => 23098, -- (0.002) 51 slots + N_Or_Else => 22858, -- (0.002) 8 slots + N_Implicit_Label_Declaration => 21687, -- (0.002) 5 slots + N_Others_Choice => 21579, -- (0.002) 4 slots + E_Out_Parameter => 21513, -- (0.002) 38 slots + N_Op_Subtract => 21441, -- (0.002) 8 slots + N_Op_Ge => 21116, -- (0.002) 8 slots + N_Component_Definition => 21075, -- (0.002) 7 slots + N_Case_Statement_Alternative => 19664, -- (0.002) 8 slots + N_Loop_Statement => 19507, -- (0.002) 9 slots + E_Package => 19029, -- (0.002) 53 slots + N_Op_Gt => 18619, -- (0.002) 8 slots + N_Op_Le => 16564, -- (0.002) 8 slots + N_Formal_Object_Declaration => 16219, -- (0.002) 7 slots + E_Discriminant => 16091, -- (0.002) 56 slots + N_Component_Declaration => 15858, -- (0.002) 7 slots + N_Iteration_Scheme => 15719, -- (0.002) 8 slots + N_Access_To_Object_Definition => 14875, -- (0.002) 5 slots + E_Record_Subtype => 14569, -- (0.001) 52 slots + N_Generic_Subprogram_Declaration => 14320, -- (0.001) 7 slots + N_Package_Specification => 13323, -- (0.001) 8 slots + N_Exception_Handler => 12841, -- (0.001) 8 slots + E_Enumeration_Literal => 11608, -- (0.001) 42 slots + N_Subprogram_Renaming_Declaration => 10991, -- (0.001) 9 slots + N_In => 10794, -- (0.001) 8 slots + E_Allocator_Type => 10751, -- (0.001) 44 slots + E_General_Access_Type => 10451, -- (0.001) 44 slots + E_Generic_Procedure => 9837, -- (0.001) 41 slots + N_Package_Renaming_Declaration => 9395, -- (0.001) 8 slots + N_Access_Definition => 9388, -- (0.001) 6 slots + N_Qualified_Expression => 9012, -- (0.001) 7 slots + E_Enumeration_Subtype => 8560, -- (0.001) 46 slots + N_Allocator => 8474, -- (0.001) 8 slots + N_Package_Declaration => 8099, -- (0.001) 10 slots + N_Formal_Type_Declaration => 7964, -- (0.001) 7 slots + N_Exit_Statement => 7960, -- (0.001) 8 slots + N_Component_List => 7829, -- (0.001) 5 slots + N_Defining_Operator_Symbol => 0, -- 7525, -- (0.001) 8 slots + N_Case_Statement => 7271, -- (0.001) 7 slots + N_Expression_Function => 7242, -- (0.001) 9 slots + N_Loop_Parameter_Specification => 7042, -- (0.001) 7 slots + N_Character_Literal => 6842, -- (0.001) 7 slots + N_Op_Concat => 6565, -- (0.001) 8 slots + N_Not_In => 6341, -- (0.001) 8 slots + N_Label => 6133, -- (0.001) 9 slots + N_Goto_Statement => 6133, -- (0.001) 8 slots + E_Label => 6133, -- (0.001) 57 slots + E_Loop => 6008, -- (0.001) 41 slots + N_Generic_Package_Declaration => 5808, -- (0.001) 10 slots + N_If_Expression => 5800, -- (0.001) 7 slots + N_Record_Definition => 5628, -- (0.001) 7 slots + N_Slice => 5461, -- (0.001) 7 slots + N_Reference => 5332, -- (0.001) 7 slots + E_Generic_Package => 5268, -- (0.001) 59 slots + E_Record_Type => 4838, -- (0.000) 51 slots + N_Raise_Program_Error => 4675, -- (0.000) 6 slots + N_Raise_Statement => 4628, -- (0.000) 8 slots + N_Use_Type_Clause => 4487, -- (0.000) 9 slots + E_Array_Type => 4325, -- (0.000) 48 slots + E_Operator => 4308, -- (0.000) 55 slots + N_Freeze_Generic_Entity => 4249, -- (0.000) 4 slots + N_Constrained_Array_Definition => 4244, -- (0.000) 5 slots + N_Object_Renaming_Declaration => 4067, -- (0.000) 8 slots + N_Formal_Private_Type_Definition => 4018, -- (0.000) 8 slots + E_Loop_Parameter => 3870, -- (0.000) 38 slots + N_Real_Literal => 3759, -- (0.000) 7 slots + N_Attribute_Definition_Clause => 3724, -- (0.000) 8 slots + N_Exception_Renaming_Declaration => 3697, -- (0.000) 8 slots + E_Class_Wide_Type => 3674, -- (0.000) 48 slots + E_Exception => 3632, -- (0.000) 24 slots + N_Range_Constraint => 3506, -- (0.000) 4 slots + E_Access_Type => 3487, -- (0.000) 44 slots + E_Subprogram_Type => 3248, -- (0.000) 47 slots + N_Package_Instantiation => 3005, -- (0.000) 8 slots + E_Access_Attribute_Type => 2959, -- (0.000) 44 slots + N_Op_And => 2957, -- (0.000) 8 slots + E_Generic_In_Parameter => 2704, -- (0.000) 31 slots + N_Derived_Type_Definition => 2688, -- (0.000) 7 slots + N_Variant => 2535, -- (0.000) 8 slots + E_Record_Subtype_With_Private => 2327, -- (0.000) 50 slots + N_Private_Type_Declaration => 2287, -- (0.000) 6 slots + E_Private_Type => 1890, -- (0.000) 48 slots + N_Discriminant_Specification => 1864, -- (0.000) 7 slots + N_Procedure_Instantiation => 1659, -- (0.000) 8 slots + N_Op_Multiply => 1634, -- (0.000) 8 slots + E_Access_Subtype => 1606, -- (0.000) 44 slots + N_Defining_Program_Unit_Name => 1463, -- (0.000) 8 slots + N_Number_Declaration => 1461, -- (0.000) 7 slots + E_Named_Integer => 1430, -- (0.000) 19 slots + N_Use_Package_Clause => 1369, -- (0.000) 9 slots + N_Compilation_Unit_Aux => 1341, -- (0.000) 8 slots + N_Compilation_Unit => 1341, -- (0.000) 8 slots + N_Elsif_Part => 1331, -- (0.000) 7 slots + N_Operator_Symbol => 1305, -- (0.000) 7 slots + E_Limited_Private_Type => 1299, -- (0.000) 48 slots + E_Generic_Function => 1292, -- (0.000) 41 slots + E_Enumeration_Type => 1186, -- (0.000) 47 slots + N_Enumeration_Type_Definition => 1169, -- (0.000) 6 slots + N_Unchecked_Expression => 1112, -- (0.000) 7 slots + N_Op_Or => 1107, -- (0.000) 8 slots + N_Designator => 1100, -- (0.000) 9 slots + N_Formal_Discrete_Type_Definition => 1086, -- (0.000) 4 slots + N_Variant_Part => 1072, -- (0.000) 8 slots + N_Formal_Package_Declaration => 1047, -- (0.000) 8 slots + N_Quantified_Expression => 1033, -- (0.000) 8 slots + E_Record_Type_With_Private => 1017, -- (0.000) 51 slots + N_Package_Body => 999, -- (0.000) 9 slots + N_Unconstrained_Array_Definition => 973, -- (0.000) 5 slots + E_Private_Subtype => 971, -- (0.000) 48 slots + N_Incomplete_Type_Declaration => 863, -- (0.000) 6 slots + E_Incomplete_Type => 863, -- (0.000) 48 slots + N_Contract => 859, -- (0.000) 6 slots + E_Package_Body => 852, -- (0.000) 46 slots + N_Extended_Return_Statement => 801, -- (0.000) 8 slots + N_Op_Divide => 724, -- (0.000) 8 slots + N_Extension_Aggregate => 718, -- (0.000) 8 slots + N_Function_Instantiation => 642, -- (0.000) 8 slots + N_Exception_Declaration => 594, -- (0.000) 7 slots + N_Discriminant_Association => 552, -- (0.000) 7 slots + N_Iterator_Specification => 543, -- (0.000) 8 slots + N_Private_Extension_Declaration => 540, -- (0.000) 8 slots + N_Formal_Signed_Integer_Type_Definition => 512, -- (0.000) 4 slots + E_Modular_Integer_Subtype => 490, -- (0.000) 44 slots + N_Component_Clause => 468, -- (0.000) 7 slots + E_Signed_Integer_Type => 399, -- (0.000) 43 slots + N_Op_Minus => 356, -- (0.000) 7 slots + N_Raise_Expression => 337, -- (0.000) 8 slots + N_Case_Expression_Alternative => 336, -- (0.000) 8 slots + N_Op_Expon => 280, -- (0.000) 8 slots + N_Abstract_Subprogram_Declaration => 250, -- (0.000) 6 slots + E_Modular_Integer_Type => 232, -- (0.000) 44 slots + N_Modular_Type_Definition => 214, -- (0.000) 7 slots + N_Compound_Statement => 212, -- (0.000) 6 slots + N_Free_Statement => 209, -- (0.000) 8 slots + N_Record_Representation_Clause => 197, -- (0.000) 9 slots + N_Access_Procedure_Definition => 195, -- (0.000) 6 slots + E_Limited_Private_Subtype => 178, -- (0.000) 48 slots + N_Access_Function_Definition => 172, -- (0.000) 7 slots + N_Op_Mod => 163, -- (0.000) 8 slots + N_Validate_Unchecked_Conversion => 156, -- (0.000) 5 slots + E_Anonymous_Access_Subprogram_Type => 155, -- (0.000) 44 slots + N_Op_Rem => 147, -- (0.000) 8 slots + N_Formal_Incomplete_Type_Definition => 140, -- (0.000) 4 slots + N_Signed_Integer_Type_Definition => 137, -- (0.000) 6 slots + N_Case_Expression => 132, -- (0.000) 7 slots + N_Op_Plus => 129, -- (0.000) 7 slots + E_Incomplete_Subtype => 129, -- (0.000) 48 slots + N_Op_Abs => 119, -- (0.000) 7 slots + N_Op_Shift_Right => 109, -- (0.000) 8 slots + E_Floating_Point_Subtype => 94, -- (0.000) 43 slots + N_Op_Shift_Left => 72, -- (0.000) 8 slots + E_Floating_Point_Type => 59, -- (0.000) 43 slots + N_Formal_Derived_Type_Definition => 53, -- (0.000) 7 slots + N_Formal_Floating_Point_Definition => 40, -- (0.000) 4 slots + N_Defining_Character_Literal => 0, -- 36, -- (0.000) 8 slots + N_Formal_Modular_Type_Definition => 27, -- (0.000) 4 slots + E_Ordinary_Fixed_Point_Subtype => 23, -- (0.000) 44 slots + E_Abstract_State => 22, -- (0.000) 48 slots + E_Named_Real => 20, -- (0.000) 19 slots + N_Floating_Point_Definition => 19, -- (0.000) 6 slots + N_Subunit => 17, -- (0.000) 8 slots + N_Enumeration_Representation_Clause => 17, -- (0.000) 9 slots + N_Entry_Declaration => 17, -- (0.000) 7 slots + N_Subprogram_Body_Stub => 16, -- (0.000) 8 slots + N_Unused_At_Start => 15, -- (0.000) 4 slots + E_Entry => 14, -- (0.000) 42 slots + N_Formal_Ordinary_Fixed_Point_Definition => 12, -- (0.000) 4 slots + E_Class_Wide_Subtype => 9, -- (0.000) 52 slots + E_Protected_Subtype => 8, -- (0.000) 48 slots + E_Ordinary_Fixed_Point_Type => 8, -- (0.000) 44 slots + N_Op_Xor => 7, -- (0.000) 8 slots + E_Generic_In_Out_Parameter => 7, -- (0.000) 31 slots + N_Protected_Type_Declaration => 6, -- (0.000) 8 slots + N_Protected_Definition => 6, -- (0.000) 8 slots + N_Task_Type_Declaration => 4, -- (0.000) 8 slots + N_Task_Definition => 4, -- (0.000) 8 slots + N_Protected_Body => 4, -- (0.000) 9 slots + E_Task_Subtype => 4, -- (0.000) 50 slots + E_Protected_Type => 4, -- (0.000) 49 slots + E_Access_Protected_Subprogram_Type => 4, -- (0.000) 45 slots + N_Entry_Call_Statement => 3, -- (0.000) 8 slots + E_Task_Type => 3, -- (0.000) 50 slots + N_Raise_Storage_Error => 2, -- (0.000) 6 slots + N_Package_Body_Stub => 2, -- (0.000) 8 slots + N_Generic_Procedure_Renaming_Declaration => 2, -- (0.000) 8 slots + N_Task_Body => 1, -- (0.000) 10 slots + N_Single_Protected_Declaration => 1, -- (0.000) 8 slots + N_Real_Range_Specification => 1, -- (0.000) 6 slots + N_Ordinary_Fixed_Point_Definition => 1, -- (0.000) 6 slots + N_Error => 1, -- (0.000) 6 slots + N_Entry_Body_Formal_Part => 1, -- (0.000) 6 slots + N_Entry_Body => 1, -- (0.000) 10 slots + N_Empty => 1, -- (0.000) 6 slots + N_Delay_Relative_Statement => 1, -- (0.000) 7 slots + E_Protected_Body => 1, -- (0.000) 35 slots + + Between_Concrete_Node_And_Concrete_Entity_Types => 0, + + -- The rest had frequency 0 (i.e. no such nodes were created in the + -- example), but we set them to 1, so we won't lose information when + -- multiplying. We use "others", so that if new node types are added, + -- we don't have to modify the table; new node types are unlikely to + -- be very common. + + others => 1 + -- N_Variable_Reference_Marker => 0, (0.000) 4 slots + -- N_Unused_At_End => 0, (0.000) 4 slots + -- N_Triggering_Alternative => 0, (0.000) 6 slots + -- N_Timed_Entry_Call => 0, (0.000) 5 slots + -- N_Terminate_Alternative => 0, (0.000) 6 slots + -- N_Task_Body_Stub => 0, (0.000) 8 slots + -- N_Target_Name => 0, (0.000) 5 slots + -- N_Single_Task_Declaration => 0, (0.000) 8 slots + -- N_Selective_Accept => 0, (0.000) 5 slots + -- N_Scil_Membership_Test => 0, (0.000) 5 slots + -- N_Scil_Dispatch_Table_Tag_Init => 0, (0.000) 4 slots + -- N_Scil_Dispatching_Call => 0, (0.000) 6 slots + -- N_Return_When_Statement => 0, (0.000) 7 slots + -- N_Requeue_Statement => 0, (0.000) 8 slots + -- N_Raise_When_Statement => 0, (0.000) 8 slots + -- N_Push_Storage_Error_Label => 0, (0.000) 4 slots + -- N_Push_Program_Error_Label => 0, (0.000) 4 slots + -- N_Push_Constraint_Error_Label => 0, (0.000) 4 slots + -- N_Protected_Body_Stub => 0, (0.000) 8 slots + -- N_Pop_Storage_Error_Label => 0, (0.000) 4 slots + -- N_Pop_Program_Error_Label => 0, (0.000) 4 slots + -- N_Pop_Constraint_Error_Label => 0, (0.000) 4 slots + -- N_Op_Shift_Right_Arithmetic => 0, (0.000) 8 slots + -- N_Op_Rotate_Right => 0, (0.000) 8 slots + -- N_Op_Rotate_Left => 0, (0.000) 8 slots + -- N_Mod_Clause => 0, (0.000) 7 slots + -- N_Iterated_Element_Association => 0, (0.000) 8 slots + -- N_Iterated_Component_Association => 0, (0.000) 8 slots + -- N_Goto_When_Statement => 0, (0.000) 8 slots + -- N_Generic_Package_Renaming_Declaration => 0, (0.000) 8 slots + -- N_Generic_Function_Renaming_Declaration => 0, (0.000) 8 slots + -- N_Formal_Decimal_Fixed_Point_Definition => 0, (0.000) 4 slots + -- N_Formal_Abstract_Subprogram_Declaration => 0, (0.000) 6 slots + -- N_Entry_Index_Specification => 0, (0.000) 7 slots + -- N_Entry_Call_Alternative => 0, (0.000) 6 slots + -- N_Digits_Constraint => 0, (0.000) 6 slots + -- N_Delta_Constraint => 0, (0.000) 6 slots + -- N_Delta_Aggregate => 0, (0.000) 8 slots + -- N_Delay_Until_Statement => 0, (0.000) 7 slots + -- N_Delay_Alternative => 0, (0.000) 7 slots + -- N_Decimal_Fixed_Point_Definition => 0, (0.000) 6 slots + -- N_Conditional_Entry_Call => 0, (0.000) 5 slots + -- N_Code_Statement => 0, (0.000) 7 slots + -- N_At_Clause => 0, (0.000) 9 slots + -- N_Asynchronous_Select => 0, (0.000) 5 slots + -- N_Accept_Statement => 0, (0.000) 8 slots + -- N_Accept_Alternative => 0, (0.000) 8 slots + -- N_Abort_Statement => 0, (0.000) 4 slots + -- N_Abortable_Part => 0, (0.000) 5 slots + -- E_Task_Body => 0, (0.000) 39 slots + -- E_Exception_Type => 0, (0.000) 45 slots + -- E_Entry_Index_Parameter => 0, (0.000) 19 slots + -- E_Entry_Family => 0, (0.000) 42 slots + -- E_Decimal_Fixed_Point_Type => 0, (0.000) 52 slots + -- E_Decimal_Fixed_Point_Subtype => 0, (0.000) 52 slots + -- E_Anonymous_Access_Protected_Subprogram_Type => 0, (0.000) 45 slots + ); -- Type_Frequency + end Gen_IL.Internals; diff --git a/gcc/ada/gen_il-types.ads b/gcc/ada/gen_il-types.ads index 321eec6..97b9dd2 100644 --- a/gcc/ada/gen_il-types.ads +++ b/gcc/ada/gen_il-types.ads @@ -77,6 +77,7 @@ package Gen_IL.Types is Node_Kind, -- root of node type hierarchy N_Access_To_Subprogram_Definition, + N_Alternative, N_Array_Type_Definition, N_Binary_Op, N_Body_Stub, @@ -84,13 +85,21 @@ package Gen_IL.Types is N_Delay_Statement, N_Direct_Name, N_Entity, + N_Entity_Name, N_Formal_Subprogram_Declaration, N_Generic_Declaration, N_Generic_Instantiation, N_Generic_Renaming_Declaration, + N_Has_Bounds, N_Has_Chars, + N_Has_Condition, N_Has_Entity, N_Has_Etype, + N_Is_Case_Choice, + N_Is_Decl, + N_Is_Exception_Choice, + N_Is_Index, + N_Is_Range, N_Multiplying_Operator, N_Later_Decl_Item, N_Membership_Test, @@ -111,7 +120,6 @@ package Gen_IL.Types is N_Statement_Other_Than_Procedure_Call, N_Subprogram_Call, N_Subprogram_Instantiation, - N_Has_Condition, N_Subexpr, N_Subprogram_Specification, N_Unary_Op, @@ -144,6 +152,7 @@ package Gen_IL.Types is Elementary_Kind, Enumeration_Kind, Entry_Kind, + Evaluable_Kind, Exception_Or_Object_Kind, Fixed_Point_Kind, Float_Kind, @@ -151,6 +160,7 @@ package Gen_IL.Types is Formal_Object_Kind, Generic_Subprogram_Kind, Generic_Unit_Kind, + Global_Name_Kind, Incomplete_Kind, Incomplete_Or_Private_Kind, Integer_Kind, @@ -167,8 +177,9 @@ package Gen_IL.Types is Record_Kind, Record_Field_Kind, Scalar_Kind, - Subprogram_Kind, Signed_Integer_Kind, + Subprogram_Type_Or_Kind, + Subprogram_Kind, Task_Kind, Type_Kind, Void_Or_Type_Kind, diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 42ea0f5..1720fe0 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -584,6 +584,15 @@ package body Ghost is -- Start of processing for Check_Ghost_Context begin + -- Class-wide pre/postconditions of ignored pragmas are preanalyzed + -- to report errors on wrong conditions; however, ignored pragmas may + -- also have references to ghost entities and we must disable checking + -- their context to avoid reporting spurious errors. + + if Inside_Class_Condition_Preanalysis then + return; + end if; + -- Once it has been established that the reference to the Ghost entity -- is within a suitable context, ensure that the policy at the point of -- declaration and at the point of use match. diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 95c1537..55f9efa 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -1695,6 +1695,10 @@ begin <<End_Of_Program>> + if Debug_Flag_Dot_AA then + Atree.Print_Statistics; + end if; + -- The outer exception handler handles an unrecoverable error exception diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb index 6273a5d..a1739be 100644 --- a/gcc/ada/gnat_cuda.adb +++ b/gcc/ada/gnat_cuda.adb @@ -25,20 +25,25 @@ -- This package defines CUDA-specific datastructures and functions. +with Atree; use Atree; with Debug; use Debug; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; +with Errout; use Errout; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; -with Sinfo; use Sinfo; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo; use Sinfo; +with Snames; use Snames; 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; @@ -54,6 +59,18 @@ package body GNAT_CUDA is function Hash (F : Entity_Id) return Hash_Range; -- Hash function for hash table + package CUDA_Device_Entities_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_Device. The values are + -- Elists of the marked entities. + package CUDA_Kernels_Table is new GNAT.HTable.Simple_HTable (Header_Num => Hash_Range, @@ -85,17 +102,60 @@ package body GNAT_CUDA is -- * A procedure that takes care of calling CUDA functions that register -- CUDA_Global procedures with the runtime. + procedure Empty_CUDA_Global_Subprograms (Pack_Id : Entity_Id); + -- For all subprograms marked CUDA_Global in Pack_Id, remove declarations + -- and replace statements with a single null statement. + -- This is required because CUDA_Global subprograms could be referring to + -- device-only symbols, which would result in unknown symbols at link time + -- if kept around. + -- We choose to empty CUDA_Global subprograms rather than completely + -- removing them from the package because registering CUDA_Global + -- subprograms with the CUDA runtime on the host requires knowing the + -- subprogram's host-side address. + + function Get_CUDA_Device_Entities (Pack_Id : Entity_Id) return Elist_Id; + -- Returns an Elist of all entities marked with pragma CUDA_Device that + -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id + -- does not contain such entities. + 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 Remove_CUDA_Device_Entities (Pack_Id : Entity_Id); + -- Removes all entities marked with the CUDA_Device pragma from package + -- Pack_Id. Must only be called when compiling for the host. + + procedure Set_CUDA_Device_Entities + (Pack_Id : Entity_Id; + E : Elist_Id); + -- Stores E as the list of CUDA_Device entities belonging to the package + -- entity Pack_Id. Pack_Id must not have a list of device entities. + 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_Device_Entity -- + ---------------------------- + + procedure Add_CUDA_Device_Entity + (Pack_Id : Entity_Id; + E : Entity_Id) + is + Device_Entities : Elist_Id := Get_CUDA_Device_Entities (Pack_Id); + begin + if Device_Entities = No_Elist then + Device_Entities := New_Elmt_List; + Set_CUDA_Device_Entities (Pack_Id, Device_Entities); + end if; + Append_Elmt (E, Device_Entities); + end Add_CUDA_Device_Entity; + --------------------- -- Add_CUDA_Kernel -- --------------------- @@ -113,6 +173,50 @@ package body GNAT_CUDA is Append_Elmt (Kernel, Kernels); end Add_CUDA_Kernel; + ----------------------------------- + -- Empty_CUDA_Global_Subprograms -- + ----------------------------------- + + procedure Empty_CUDA_Global_Subprograms (Pack_Id : Entity_Id) is + Spec_Id : constant Node_Id := Corresponding_Spec (Pack_Id); + Kernels : constant Elist_Id := Get_CUDA_Kernels (Spec_Id); + Kernel_Elm : Elmt_Id; + Kernel : Entity_Id; + Kernel_Body : Node_Id; + Null_Body : Entity_Id; + Loc : Source_Ptr; + begin + -- It is an error to empty CUDA_Global subprograms when not compiling + -- for the host. + pragma Assert (Debug_Flag_Underscore_C); + + if No (Kernels) then + return; + end if; + + Kernel_Elm := First_Elmt (Kernels); + while Present (Kernel_Elm) loop + Kernel := Node (Kernel_Elm); + Kernel_Body := Subprogram_Body (Kernel); + Loc := Sloc (Kernel_Body); + + Null_Body := Make_Subprogram_Body (Loc, + Specification => Subprogram_Specification (Kernel), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Make_Null_Statement (Loc)))); + + Rewrite (Kernel_Body, Null_Body); + + Next_Elmt (Kernel_Elm); + end loop; + end Empty_CUDA_Global_Subprograms; + + ------------------------- + -- Expand_CUDA_Package -- + ------------------------- + procedure Expand_CUDA_Package (N : Node_Id) is begin @@ -122,6 +226,20 @@ package body GNAT_CUDA is return; end if; + -- Remove the content (both declarations and statements) of CUDA_Global + -- procedures. This is required because CUDA_Global functions could be + -- referencing entities available only on the device, which would result + -- in unknown symbol errors at link time. + + Empty_CUDA_Global_Subprograms (N); + + -- Remove CUDA_Device entities (except if they are also CUDA_Host), as + -- they can only be referenced from the device and might reference + -- device-only symbols. + + Remove_CUDA_Device_Entities + (Package_Specification (Corresponding_Spec (N))); + -- 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 @@ -139,6 +257,15 @@ package body GNAT_CUDA is return Hash_Range (F mod 511); end Hash; + ------------------------------ + -- Get_CUDA_Device_Entities -- + ------------------------------ + + function Get_CUDA_Device_Entities (Pack_Id : Entity_Id) return Elist_Id is + begin + return CUDA_Device_Entities_Table.Get (Pack_Id); + end Get_CUDA_Device_Entities; + ---------------------- -- Get_CUDA_Kernels -- ---------------------- @@ -605,9 +732,70 @@ package body GNAT_CUDA is Analyze (New_Stmt); end Build_And_Insert_CUDA_Initialization; - -------------------- - -- Set_CUDA_Nodes -- - -------------------- + --------------------------------- + -- Remove_CUDA_Device_Entities -- + --------------------------------- + + procedure Remove_CUDA_Device_Entities (Pack_Id : Entity_Id) is + Device_Entities : constant Elist_Id := + Get_CUDA_Device_Entities (Pack_Id); + Device_Elmt : Elmt_Id; + Device_Entity : Entity_Id; + Bod : Node_Id; + begin + pragma Assert (Debug_Flag_Underscore_C); + + if Device_Entities = No_Elist then + return; + end if; + + Device_Elmt := First_Elmt (Device_Entities); + while Present (Device_Elmt) loop + Device_Entity := Node (Device_Elmt); + Next_Elmt (Device_Elmt); + + case Ekind (Device_Entity) is + when E_Function | E_Procedure => + Bod := Subprogram_Body (Device_Entity); + + if Nkind (Parent (Bod)) = N_Subunit + and then Present (Corresponding_Stub (Parent (Bod))) + then + Error_Msg_N + ("Cuda_Device not suported on separate subprograms", + Corresponding_Stub (Parent (Bod))); + else + Remove (Bod); + Remove (Subprogram_Spec (Device_Entity)); + end if; + + when E_Variable | E_Constant => + Remove (Declaration_Node (Device_Entity)); + + when others => + pragma Assert (False); + end case; + + Remove_Entity_And_Homonym (Device_Entity); + end loop; + end Remove_CUDA_Device_Entities; + + ------------------------------ + -- Set_CUDA_Device_Entities -- + ------------------------------ + + procedure Set_CUDA_Device_Entities + (Pack_Id : Entity_Id; + E : Elist_Id) + is + begin + pragma Assert (Get_CUDA_Device_Entities (Pack_Id) = No_Elist); + CUDA_Device_Entities_Table.Set (Pack_Id, E); + end Set_CUDA_Device_Entities; + + ---------------------- + -- Set_CUDA_Kernels -- + ---------------------- procedure Set_CUDA_Kernels (Pack_Id : Entity_Id; diff --git a/gcc/ada/gnat_cuda.ads b/gcc/ada/gnat_cuda.ads index d35bc8a..390f5de 100644 --- a/gcc/ada/gnat_cuda.ads +++ b/gcc/ada/gnat_cuda.ads @@ -77,13 +77,19 @@ with Types; use Types; package GNAT_CUDA is + procedure Add_CUDA_Device_Entity (Pack_Id : Entity_Id; E : Entity_Id); + -- And E to the list of CUDA_Device entities that belong to Pack_Id + 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 Expand_CUDA_Package (N : Node_Id); - -- When compiling for the host, generate code to register kernels with the - -- CUDA runtime and post-process kernels. + -- When compiling for the host: + -- - Generate code to register kernels with the CUDA runtime and + -- post-process kernels. + -- - Empty content of CUDA_Global procedures. + -- - Remove declarations of CUDA_Device entities. end GNAT_CUDA; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 349586e..0a962ee 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Jun 23, 2021 +GNAT Reference Manual , Sep 28, 2021 AdaCore @@ -79,6 +79,7 @@ included in the section entitled @ref{1,,GNU Free Documentation License}. * Specialized Needs Annexes:: * Implementation of Specific Ada Features:: * Implementation of Ada 2012 Features:: +* Security Hardening Features:: * Obsolescent Features:: * Compatibility and Porting Guide:: * GNU Free Documentation License:: @@ -224,7 +225,6 @@ Implementation Defined Pragmas * Pragma Post:: * Pragma Postcondition:: * Pragma Post_Class:: -* Pragma Rename_Pragma:: * Pragma Pre:: * Pragma Precondition:: * Pragma Predicate:: @@ -247,6 +247,7 @@ Implementation Defined Pragmas * Pragma Refined_State:: * Pragma Relative_Deadline:: * Pragma Remote_Access_Type:: +* Pragma Rename_Pragma:: * Pragma Restricted_Run_Time:: * Pragma Restriction_Warnings:: * Pragma Reviewable:: @@ -529,6 +530,7 @@ Partition-Wide Restrictions Program Unit Level Restrictions * No_Elaboration_Code:: +* No_Dynamic_Accessibility_Checks:: * No_Dynamic_Sized_Objects:: * No_Entry_Queue:: * No_Implementation_Aspect_Specifications:: @@ -877,6 +879,11 @@ Code Generation for Array Aggregates * Aggregates with nonstatic bounds:: * Aggregates in assignment statements:: +Security Hardening Features + +* Register Scrubbing:: +* Stack Scrubbing:: + Obsolescent Features * pragma No_Run_Time:: @@ -1033,13 +1040,17 @@ other features. GNAT implementation of the Ada 2012 language standard. @item -@ref{15,,Obsolescent Features} documents implementation dependent features, +@ref{15,,Security Hardening Features} documents GNAT extensions aimed +at security hardening. + +@item +@ref{16,,Obsolescent Features} documents implementation dependent features, including pragmas and attributes, which are considered obsolescent, since there are other preferred ways of achieving the same results. These obsolescent forms are retained for backwards compatibility. @item -@ref{16,,Compatibility and Porting Guide} presents some guidelines for +@ref{17,,Compatibility and Porting Guide} presents some guidelines for developing portable Ada code, describes the compatibility issues that may arise between GNAT and other Ada compilation systems (including those for Ada 83), and shows how GNAT can expedite porting applications @@ -1062,7 +1073,7 @@ All three reference manuals are included in the GNAT documentation package. @node Conventions,Related Information,What This Reference Manual Contains,About This Guide -@anchor{gnat_rm/about_this_guide conventions}@anchor{17} +@anchor{gnat_rm/about_this_guide conventions}@anchor{18} @section Conventions @@ -1109,7 +1120,7 @@ comprising the @code{$} character followed by a space. @end itemize @node Related Information,,Conventions,About This Guide -@anchor{gnat_rm/about_this_guide related-information}@anchor{18} +@anchor{gnat_rm/about_this_guide related-information}@anchor{19} @section Related Information @@ -1155,7 +1166,7 @@ compiler system. @end itemize @node Implementation Defined Pragmas,Implementation Defined Aspects,About This Guide,Top -@anchor{gnat_rm/implementation_defined_pragmas doc}@anchor{19}@anchor{gnat_rm/implementation_defined_pragmas id1}@anchor{1a}@anchor{gnat_rm/implementation_defined_pragmas implementation-defined-pragmas}@anchor{7} +@anchor{gnat_rm/implementation_defined_pragmas doc}@anchor{1a}@anchor{gnat_rm/implementation_defined_pragmas id1}@anchor{1b}@anchor{gnat_rm/implementation_defined_pragmas implementation-defined-pragmas}@anchor{7} @chapter Implementation Defined Pragmas @@ -1304,7 +1315,6 @@ consideration, the use of these pragmas should be minimized. * Pragma Post:: * Pragma Postcondition:: * Pragma Post_Class:: -* Pragma Rename_Pragma:: * Pragma Pre:: * Pragma Precondition:: * Pragma Predicate:: @@ -1327,6 +1337,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Refined_State:: * Pragma Relative_Deadline:: * Pragma Remote_Access_Type:: +* Pragma Rename_Pragma:: * Pragma Restricted_Run_Time:: * Pragma Restriction_Warnings:: * Pragma Reviewable:: @@ -1380,7 +1391,7 @@ consideration, the use of these pragmas should be minimized. @end menu @node Pragma Abort_Defer,Pragma Abstract_State,,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-abort-defer}@anchor{1b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-abort-defer}@anchor{1c} @section Pragma Abort_Defer @@ -1413,7 +1424,7 @@ end; @end example @node Pragma Abstract_State,Pragma Ada_83,Pragma Abort_Defer,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{1c}@anchor{gnat_rm/implementation_defined_pragmas pragma-abstract-state}@anchor{1d} +@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{1d}@anchor{gnat_rm/implementation_defined_pragmas pragma-abstract-state}@anchor{1e} @section Pragma Abstract_State @@ -1463,7 +1474,7 @@ For the semantics of this pragma, see the entry for aspect @code{Abstract_State} the SPARK 2014 Reference Manual, section 7.1.4. @node Pragma Ada_83,Pragma Ada_95,Pragma Abstract_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-83}@anchor{1e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-83}@anchor{1f} @section Pragma Ada_83 @@ -1492,7 +1503,7 @@ by GNAT in Ada 83 mode will in fact compile and execute with an Ada required by Ada 83. @node Pragma Ada_95,Pragma Ada_05,Pragma Ada_83,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-95}@anchor{1f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-95}@anchor{20} @section Pragma Ada_95 @@ -1511,7 +1522,7 @@ itself uses Ada 95 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. @node Pragma Ada_05,Pragma Ada_2005,Pragma Ada_95,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{20} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{21} @section Pragma Ada_05 @@ -1540,7 +1551,7 @@ otherwise legal pre-Ada_2005 programs. The one argument form is intended for exclusive use in the GNAT run-time library. @node Pragma Ada_2005,Pragma Ada_12,Pragma Ada_05,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2005}@anchor{21} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2005}@anchor{22} @section Pragma Ada_2005 @@ -1554,7 +1565,7 @@ This configuration pragma is a synonym for pragma Ada_05 and has the same syntax and effect. @node Pragma Ada_12,Pragma Ada_2012,Pragma Ada_2005,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-12}@anchor{22} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-12}@anchor{23} @section Pragma Ada_12 @@ -1585,7 +1596,7 @@ otherwise legal pre-Ada_2012 programs. The one argument form is intended for exclusive use in the GNAT run-time library. @node Pragma Ada_2012,Pragma Aggregate_Individually_Assign,Pragma Ada_12,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2012}@anchor{23} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2012}@anchor{24} @section Pragma Ada_2012 @@ -1599,7 +1610,7 @@ This configuration pragma is a synonym for pragma Ada_12 and has the same syntax and effect. @node Pragma Aggregate_Individually_Assign,Pragma Allow_Integer_Address,Pragma Ada_2012,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-aggregate-individually-assign}@anchor{24} +@anchor{gnat_rm/implementation_defined_pragmas pragma-aggregate-individually-assign}@anchor{25} @section Pragma Aggregate_Individually_Assign @@ -1615,7 +1626,7 @@ this behavior so that record aggregates are instead always converted into individual assignment statements. @node Pragma Allow_Integer_Address,Pragma Annotate,Pragma Aggregate_Individually_Assign,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-allow-integer-address}@anchor{25} +@anchor{gnat_rm/implementation_defined_pragmas pragma-allow-integer-address}@anchor{26} @section Pragma Allow_Integer_Address @@ -1665,7 +1676,7 @@ rather than rejected to allow common sets of sources to be used in the two situations. @node Pragma Annotate,Pragma Assert,Pragma Allow_Integer_Address,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{26}@anchor{gnat_rm/implementation_defined_pragmas pragma-annotate}@anchor{27} +@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{27}@anchor{gnat_rm/implementation_defined_pragmas pragma-annotate}@anchor{28} @section Pragma Annotate @@ -1700,7 +1711,7 @@ affect the compilation process in any way. This pragma may be used as a configuration pragma. @node Pragma Assert,Pragma Assert_And_Cut,Pragma Annotate,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-assert}@anchor{28} +@anchor{gnat_rm/implementation_defined_pragmas pragma-assert}@anchor{29} @section Pragma Assert @@ -1766,7 +1777,7 @@ of Ada, and the DISABLE policy is an implementation-defined addition. @node Pragma Assert_And_Cut,Pragma Assertion_Policy,Pragma Assert,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-assert-and-cut}@anchor{29} +@anchor{gnat_rm/implementation_defined_pragmas pragma-assert-and-cut}@anchor{2a} @section Pragma Assert_And_Cut @@ -1793,7 +1804,7 @@ formal verification. The pragma also serves as useful documentation. @node Pragma Assertion_Policy,Pragma Assume,Pragma Assert_And_Cut,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-assertion-policy}@anchor{2a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-assertion-policy}@anchor{2b} @section Pragma Assertion_Policy @@ -1880,7 +1891,7 @@ applies to @code{Assert}, @code{Assert_And_Cut}, @code{Assume}, @code{Loop_Invariant}, and @code{Loop_Variant}. @node Pragma Assume,Pragma Assume_No_Invalid_Values,Pragma Assertion_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-assume}@anchor{2b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-assume}@anchor{2c} @section Pragma Assume @@ -1914,7 +1925,7 @@ is met, and documents the need to ensure that it is met by reference to information outside the program. @node Pragma Assume_No_Invalid_Values,Pragma Async_Readers,Pragma Assume,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-assume-no-invalid-values}@anchor{2c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-assume-no-invalid-values}@anchor{2d} @section Pragma Assume_No_Invalid_Values @@ -1967,7 +1978,7 @@ is erroneous so there are no guarantees that this will always be the case, and it is recommended that these two options not be used together. @node Pragma Async_Readers,Pragma Async_Writers,Pragma Assume_No_Invalid_Values,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{2d}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-readers}@anchor{2e} +@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{2e}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-readers}@anchor{2f} @section Pragma Async_Readers @@ -1981,7 +1992,7 @@ For the semantics of this pragma, see the entry for aspect @code{Async_Readers} the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Async_Writers,Pragma Attribute_Definition,Pragma Async_Readers,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{2f}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-writers}@anchor{30} +@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{30}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-writers}@anchor{31} @section Pragma Async_Writers @@ -1995,7 +2006,7 @@ For the semantics of this pragma, see the entry for aspect @code{Async_Writers} the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Attribute_Definition,Pragma C_Pass_By_Copy,Pragma Async_Writers,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-attribute-definition}@anchor{31} +@anchor{gnat_rm/implementation_defined_pragmas pragma-attribute-definition}@anchor{32} @section Pragma Attribute_Definition @@ -2021,7 +2032,7 @@ code to be written that takes advantage of some new attribute, while remaining compilable with earlier compilers. @node Pragma C_Pass_By_Copy,Pragma Check,Pragma Attribute_Definition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-c-pass-by-copy}@anchor{32} +@anchor{gnat_rm/implementation_defined_pragmas pragma-c-pass-by-copy}@anchor{33} @section Pragma C_Pass_By_Copy @@ -2065,7 +2076,7 @@ You can also pass records by copy by specifying the convention passing mechanisms on a parameter by parameter basis. @node Pragma Check,Pragma Check_Float_Overflow,Pragma C_Pass_By_Copy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-check}@anchor{33} +@anchor{gnat_rm/implementation_defined_pragmas pragma-check}@anchor{34} @section Pragma Check @@ -2104,7 +2115,7 @@ of these identifiers in @code{Assertion_Policy} and @code{Check_Policy} pragmas, where they are used to refer to sets of assertions. @node Pragma Check_Float_Overflow,Pragma Check_Name,Pragma Check,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-check-float-overflow}@anchor{34} +@anchor{gnat_rm/implementation_defined_pragmas pragma-check-float-overflow}@anchor{35} @section Pragma Check_Float_Overflow @@ -2160,7 +2171,7 @@ This mode can also be set by use of the compiler switch @emph{-gnateF}. @node Pragma Check_Name,Pragma Check_Policy,Pragma Check_Float_Overflow,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-check-name}@anchor{35} +@anchor{gnat_rm/implementation_defined_pragmas pragma-check-name}@anchor{36} @section Pragma Check_Name @@ -2196,7 +2207,7 @@ Check names introduced by this pragma are subject to control by compiler switches (in particular -gnatp) in the usual manner. @node Pragma Check_Policy,Pragma Comment,Pragma Check_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-check-policy}@anchor{36} +@anchor{gnat_rm/implementation_defined_pragmas pragma-check-policy}@anchor{37} @section Pragma Check_Policy @@ -2276,7 +2287,7 @@ policy setting @code{DISABLE} causes the second argument of a corresponding @code{Check} pragma to be completely ignored and not analyzed. @node Pragma Comment,Pragma Common_Object,Pragma Check_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{37} +@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{38} @section Pragma Comment @@ -2295,7 +2306,7 @@ anywhere in the main source unit), and if more than one pragma is used, all comments are retained. @node Pragma Common_Object,Pragma Compile_Time_Error,Pragma Comment,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{38} +@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{39} @section Pragma Common_Object @@ -2327,7 +2338,7 @@ indicating that the necessary attribute for implementation of this pragma is not available. @node Pragma Compile_Time_Error,Pragma Compile_Time_Warning,Pragma Common_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas compile-time-error}@anchor{39}@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{3a} +@anchor{gnat_rm/implementation_defined_pragmas compile-time-error}@anchor{3a}@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{3b} @section Pragma Compile_Time_Error @@ -2354,7 +2365,7 @@ the value given as the second argument. This string value may contain embedded ASCII.LF characters to break the message into multiple lines. @node Pragma Compile_Time_Warning,Pragma Compiler_Unit,Pragma Compile_Time_Error,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{3b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{3c} @section Pragma Compile_Time_Warning @@ -2381,11 +2392,11 @@ for example that it is not fully implemented. In previous versions of the compiler, combining @emph{-gnatwe} with Compile_Time_Warning resulted in a fatal error. Now the compiler always emits -a warning. You can use @ref{39,,Pragma Compile_Time_Error} to force the generation of +a warning. You can use @ref{3a,,Pragma Compile_Time_Error} to force the generation of an error. @node Pragma Compiler_Unit,Pragma Compiler_Unit_Warning,Pragma Compile_Time_Warning,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{3c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{3d} @section Pragma Compiler_Unit @@ -2400,7 +2411,7 @@ retained so that old versions of the GNAT run-time that use this pragma can be compiled with newer versions of the compiler. @node Pragma Compiler_Unit_Warning,Pragma Complete_Representation,Pragma Compiler_Unit,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{3d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{3e} @section Pragma Compiler_Unit_Warning @@ -2418,7 +2429,7 @@ version of GNAT. For the exact list of restrictions, see the compiler sources and references to Check_Compiler_Unit. @node Pragma Complete_Representation,Pragma Complex_Representation,Pragma Compiler_Unit_Warning,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{3e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{3f} @section Pragma Complete_Representation @@ -2437,7 +2448,7 @@ complete, and that this invariant is maintained if fields are added to the record in the future. @node Pragma Complex_Representation,Pragma Component_Alignment,Pragma Complete_Representation,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{3f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{40} @section Pragma Complex_Representation @@ -2459,7 +2470,7 @@ records by pointer, and the use of this pragma may result in passing this type in floating-point registers. @node Pragma Component_Alignment,Pragma Constant_After_Elaboration,Pragma Complex_Representation,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{40} +@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{41} @section Pragma Component_Alignment @@ -2550,7 +2561,7 @@ pragma @code{Pack}, pragma @code{Component_Alignment}, or a record rep clause), the GNAT uses the default alignment as described previously. @node Pragma Constant_After_Elaboration,Pragma Contract_Cases,Pragma Component_Alignment,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id6}@anchor{41}@anchor{gnat_rm/implementation_defined_pragmas pragma-constant-after-elaboration}@anchor{42} +@anchor{gnat_rm/implementation_defined_pragmas id6}@anchor{42}@anchor{gnat_rm/implementation_defined_pragmas pragma-constant-after-elaboration}@anchor{43} @section Pragma Constant_After_Elaboration @@ -2564,7 +2575,7 @@ For the semantics of this pragma, see the entry for aspect @code{Constant_After_Elaboration} in the SPARK 2014 Reference Manual, section 3.3.1. @node Pragma Contract_Cases,Pragma Convention_Identifier,Pragma Constant_After_Elaboration,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id7}@anchor{43}@anchor{gnat_rm/implementation_defined_pragmas pragma-contract-cases}@anchor{44} +@anchor{gnat_rm/implementation_defined_pragmas id7}@anchor{44}@anchor{gnat_rm/implementation_defined_pragmas pragma-contract-cases}@anchor{45} @section Pragma Contract_Cases @@ -2649,7 +2660,7 @@ and that the consequence for this case should hold when the subprogram returns. @node Pragma Convention_Identifier,Pragma CPP_Class,Pragma Contract_Cases,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-convention-identifier}@anchor{45} +@anchor{gnat_rm/implementation_defined_pragmas pragma-convention-identifier}@anchor{46} @section Pragma Convention_Identifier @@ -2685,7 +2696,7 @@ define a convention identifier @code{Library} and use a single would be used system-wide. @node Pragma CPP_Class,Pragma CPP_Constructor,Pragma Convention_Identifier,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-class}@anchor{46} +@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-class}@anchor{47} @section Pragma CPP_Class @@ -2710,14 +2721,14 @@ functions (see pragma @code{CPP_Constructor}). Such types are implicitly limited if not explicitly declared as limited or derived from a limited type, and an error is issued in that case. -See @ref{47,,Interfacing to C++} for related information. +See @ref{48,,Interfacing to C++} for related information. Note: Pragma @code{CPP_Class} is currently obsolete. It is supported for backward compatibility but its functionality is available using pragma @code{Import} with @code{Convention} = @code{CPP}. @node Pragma CPP_Constructor,Pragma CPP_Virtual,Pragma CPP_Class,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-constructor}@anchor{48} +@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-constructor}@anchor{49} @section Pragma CPP_Constructor @@ -2768,7 +2779,7 @@ on the Ada side and the type is implicitly declared abstract. Pragma @code{CPP_Constructor} is intended primarily for automatic generation using an automatic binding generator tool (such as the @code{-fdump-ada-spec} GCC switch). -See @ref{47,,Interfacing to C++} for more related information. +See @ref{48,,Interfacing to C++} for more related information. Note: The use of functions returning class-wide types for constructors is currently obsolete. They are supported for backward compatibility. The @@ -2777,7 +2788,7 @@ because the imported C++ constructors always return an object of type T; that is, they never return an object whose type is a descendant of type T. @node Pragma CPP_Virtual,Pragma CPP_Vtable,Pragma CPP_Constructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-virtual}@anchor{49} +@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-virtual}@anchor{4a} @section Pragma CPP_Virtual @@ -2790,10 +2801,10 @@ purposes. It used to be required to ensure compoatibility with C++, but is no longer required for that purpose because GNAT generates the same object layout as the G++ compiler by default. -See @ref{47,,Interfacing to C++} for related information. +See @ref{48,,Interfacing to C++} for related information. @node Pragma CPP_Vtable,Pragma CPU,Pragma CPP_Virtual,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-vtable}@anchor{4a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-vtable}@anchor{4b} @section Pragma CPP_Vtable @@ -2805,10 +2816,10 @@ It used to be required to ensure compatibility with C++, but is no longer required for that purpose because GNAT generates the same object layout as the G++ compiler by default. -See @ref{47,,Interfacing to C++} for related information. +See @ref{48,,Interfacing to C++} for related information. @node Pragma CPU,Pragma Deadline_Floor,Pragma CPP_Vtable,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-cpu}@anchor{4b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-cpu}@anchor{4c} @section Pragma CPU @@ -2823,7 +2834,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Deadline_Floor,Pragma Default_Initial_Condition,Pragma CPU,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-deadline-floor}@anchor{4c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-deadline-floor}@anchor{4d} @section Pragma Deadline_Floor @@ -2838,7 +2849,7 @@ deadline inherited by a task when the task enters a protected object. It is effective only when the EDF scheduling policy is used. @node Pragma Default_Initial_Condition,Pragma Debug,Pragma Deadline_Floor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id8}@anchor{4d}@anchor{gnat_rm/implementation_defined_pragmas pragma-default-initial-condition}@anchor{4e} +@anchor{gnat_rm/implementation_defined_pragmas id8}@anchor{4e}@anchor{gnat_rm/implementation_defined_pragmas pragma-default-initial-condition}@anchor{4f} @section Pragma Default_Initial_Condition @@ -2852,7 +2863,7 @@ For the semantics of this pragma, see the entry for aspect @code{Default_Initial_Condition} in the SPARK 2014 Reference Manual, section 7.3.3. @node Pragma Debug,Pragma Debug_Policy,Pragma Default_Initial_Condition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{4f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{50} @section Pragma Debug @@ -2880,7 +2891,7 @@ or by use of the pragma @code{Check_Policy} with a first argument of @code{Debug}. @node Pragma Debug_Policy,Pragma Default_Scalar_Storage_Order,Pragma Debug,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{50} +@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{51} @section Pragma Debug_Policy @@ -2895,7 +2906,7 @@ with a first argument of @code{Debug}. It is retained for historical compatibility reasons. @node Pragma Default_Scalar_Storage_Order,Pragma Default_Storage_Pool,Pragma Debug_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{51} +@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{52} @section Pragma Default_Scalar_Storage_Order @@ -2968,7 +2979,7 @@ it may significantly degrade the run-time performance of the software, instead the default scalar storage order ought to be changed only on a local basis. @node Pragma Default_Storage_Pool,Pragma Depends,Pragma Default_Scalar_Storage_Order,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{52} +@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{53} @section Pragma Default_Storage_Pool @@ -2985,7 +2996,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Depends,Pragma Detect_Blocking,Pragma Default_Storage_Pool,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id9}@anchor{53}@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{54} +@anchor{gnat_rm/implementation_defined_pragmas id9}@anchor{54}@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{55} @section Pragma Depends @@ -3018,7 +3029,7 @@ For the semantics of this pragma, see the entry for aspect @code{Depends} in the SPARK 2014 Reference Manual, section 6.1.5. @node Pragma Detect_Blocking,Pragma Disable_Atomic_Synchronization,Pragma Depends,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{55} +@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{56} @section Pragma Detect_Blocking @@ -3036,7 +3047,7 @@ blocking operations within a protected operation, and to raise Program_Error if that happens. @node Pragma Disable_Atomic_Synchronization,Pragma Dispatching_Domain,Pragma Detect_Blocking,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{56} +@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{57} @section Pragma Disable_Atomic_Synchronization @@ -3062,7 +3073,7 @@ till the end of the scope. If an @code{Entity} argument is present, the action applies only to that entity. @node Pragma Dispatching_Domain,Pragma Effective_Reads,Pragma Disable_Atomic_Synchronization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{57} +@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{58} @section Pragma Dispatching_Domain @@ -3077,7 +3088,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Effective_Reads,Pragma Effective_Writes,Pragma Dispatching_Domain,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id10}@anchor{58}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{59} +@anchor{gnat_rm/implementation_defined_pragmas id10}@anchor{59}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{5a} @section Pragma Effective_Reads @@ -3091,7 +3102,7 @@ For the semantics of this pragma, see the entry for aspect @code{Effective_Reads the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Effective_Writes,Pragma Elaboration_Checks,Pragma Effective_Reads,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id11}@anchor{5a}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{5b} +@anchor{gnat_rm/implementation_defined_pragmas id11}@anchor{5b}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{5c} @section Pragma Effective_Writes @@ -3105,7 +3116,7 @@ For the semantics of this pragma, see the entry for aspect @code{Effective_Write in the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma Elaboration_Checks,Pragma Eliminate,Pragma Effective_Writes,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{5c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{5d} @section Pragma Elaboration_Checks @@ -3142,7 +3153,7 @@ effect. If the pragma argument is @code{Static}, then the static elaboration mod is in effect. @node Pragma Eliminate,Pragma Enable_Atomic_Synchronization,Pragma Elaboration_Checks,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{5d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{5e} @section Pragma Eliminate @@ -3302,7 +3313,7 @@ pragma Eliminate (Q, Proc, @end quotation @node Pragma Enable_Atomic_Synchronization,Pragma Export_Function,Pragma Eliminate,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{5e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{5f} @section Pragma Enable_Atomic_Synchronization @@ -3330,7 +3341,7 @@ till the end of the scope. If an @code{Entity} argument is present, the action applies only to that entity. @node Pragma Export_Function,Pragma Export_Object,Pragma Enable_Atomic_Synchronization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{5f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{60} @section Pragma Export_Function @@ -3402,7 +3413,7 @@ string. In this case, no external name is generated. This form still allows the specification of parameter mechanisms. @node Pragma Export_Object,Pragma Export_Procedure,Pragma Export_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{60} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{61} @section Pragma Export_Object @@ -3427,7 +3438,7 @@ of portability), but it is not required. @code{Size} is syntax checked, but otherwise ignored by GNAT. @node Pragma Export_Procedure,Pragma Export_Valued_Procedure,Pragma Export_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{61} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{62} @section Pragma Export_Procedure @@ -3480,7 +3491,7 @@ string. In this case, no external name is generated. This form still allows the specification of parameter mechanisms. @node Pragma Export_Valued_Procedure,Pragma Extend_System,Pragma Export_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{62} +@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{63} @section Pragma Export_Valued_Procedure @@ -3538,7 +3549,7 @@ string. In this case, no external name is generated. This form still allows the specification of parameter mechanisms. @node Pragma Extend_System,Pragma Extensions_Allowed,Pragma Export_Valued_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{63} +@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{64} @section Pragma Extend_System @@ -3589,7 +3600,7 @@ for compiling System units, as explained in the GNAT User’s Guide. @node Pragma Extensions_Allowed,Pragma Extensions_Visible,Pragma Extend_System,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{64} +@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{65} @section Pragma Extensions_Allowed @@ -3698,8 +3709,15 @@ will not be executed if the earlier alternative “matches”). All possible values of the composite type shall be covered. The composite type of the selector shall be a nonlimited untagged (but possibly discriminated) record type, all of whose subcomponent subtypes are either static discrete -subtypes or record types that meet the same restrictions. Support for arrays -is planned, but not yet implemented. +subtypes or record types that meet the same restrictions. + +Support for casing on arrays (and on records that contain arrays) is +currently subject to some restrictions. Non-positional +array aggregates are not supported as (or within) case choices. Likewise +for array type and subtype names. The current implementation exceeds +compile-time capacity limits in some annoyingly common scenarios; the +message generated in such cases is usually “Capacity exceeded in compiling +case statement with composite selector type”. In addition, pattern bindings are supported. This is a mechanism for binding a name to a component of a matching value for use within @@ -3708,7 +3726,8 @@ that occurs within a case choice, the expression may be followed by “is <identifier>”. In the special case of a “box” component association, the identifier may instead be provided within the box. Either of these indicates that the given identifer denotes (a constant view of) the matching -subcomponent of the case selector. +subcomponent of the case selector. Binding is not yet supported for arrays +or subcomponents thereof. Consider this example (which uses type Rec from the previous example): @@ -3813,7 +3832,7 @@ name, preference is given to the component in a selected_component @end itemize @node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{65}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{66} +@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{66}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{67} @section Pragma Extensions_Visible @@ -3827,7 +3846,7 @@ For the semantics of this pragma, see the entry for aspect @code{Extensions_Visi in the SPARK 2014 Reference Manual, section 6.1.7. @node Pragma External,Pragma External_Name_Casing,Pragma Extensions_Visible,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{67} +@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{68} @section Pragma External @@ -3848,7 +3867,7 @@ used this pragma for exactly the same purposes as pragma @code{Export} before the latter was standardized. @node Pragma External_Name_Casing,Pragma Fast_Math,Pragma External,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{68} +@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{69} @section Pragma External_Name_Casing @@ -3937,7 +3956,7 @@ pragma External_Name_Casing (Uppercase, Uppercase); to enforce the upper casing of all external symbols. @node Pragma Fast_Math,Pragma Favor_Top_Level,Pragma External_Name_Casing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{69} +@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{6a} @section Pragma Fast_Math @@ -3966,7 +3985,7 @@ under control of the pragma, rather than use the preinstantiated versions. @end table @node Pragma Favor_Top_Level,Pragma Finalize_Storage_Only,Pragma Fast_Math,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{6a}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6b} +@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{6b}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{6c} @section Pragma Favor_Top_Level @@ -3985,7 +4004,7 @@ When this pragma is used, dynamically generated trampolines may be used on some targets for nested subprograms. See restriction @code{No_Implicit_Dynamic_Code}. @node Pragma Finalize_Storage_Only,Pragma Float_Representation,Pragma Favor_Top_Level,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{6c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{6d} @section Pragma Finalize_Storage_Only @@ -4005,7 +4024,7 @@ name. Note that this pragma does not suppress Finalize calls for library-level heap-allocated objects (see pragma @code{No_Heap_Finalization}). @node Pragma Float_Representation,Pragma Ghost,Pragma Finalize_Storage_Only,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{6d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{6e} @section Pragma Float_Representation @@ -4040,7 +4059,7 @@ No other value of digits is permitted. @end itemize @node Pragma Ghost,Pragma Global,Pragma Float_Representation,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{6e}@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{6f} +@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{6f}@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{70} @section Pragma Ghost @@ -4054,7 +4073,7 @@ For the semantics of this pragma, see the entry for aspect @code{Ghost} in the S 2014 Reference Manual, section 6.9. @node Pragma Global,Pragma Ident,Pragma Ghost,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{70}@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{71} +@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{71}@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{72} @section Pragma Global @@ -4079,7 +4098,7 @@ For the semantics of this pragma, see the entry for aspect @code{Global} in the SPARK 2014 Reference Manual, section 6.1.4. @node Pragma Ident,Pragma Ignore_Pragma,Pragma Global,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{72} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{73} @section Pragma Ident @@ -4093,7 +4112,7 @@ This pragma is identical in effect to pragma @code{Comment}. It is provided for compatibility with other Ada compilers providing this pragma. @node Pragma Ignore_Pragma,Pragma Implementation_Defined,Pragma Ident,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{73} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{74} @section Pragma Ignore_Pragma @@ -4113,7 +4132,7 @@ pragma allows such pragmas to be ignored, which may be useful in CodePeer mode, or during porting of legacy code. @node Pragma Implementation_Defined,Pragma Implemented,Pragma Ignore_Pragma,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{74} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{75} @section Pragma Implementation_Defined @@ -4140,7 +4159,7 @@ for the purpose of implementing the No_Implementation_Identifiers restriction. @node Pragma Implemented,Pragma Implicit_Packing,Pragma Implementation_Defined,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{75} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{76} @section Pragma Implemented @@ -4186,7 +4205,7 @@ By_Any shares the behavior of By_Entry and By_Protected_Procedure depending on the target’s overriding subprogram kind. @node Pragma Implicit_Packing,Pragma Import_Function,Pragma Implemented,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{76} +@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{77} @section Pragma Implicit_Packing @@ -4240,7 +4259,7 @@ sufficient. The use of pragma Implicit_Packing allows this record declaration to compile without an explicit pragma Pack. @node Pragma Import_Function,Pragma Import_Object,Pragma Implicit_Packing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{77} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{78} @section Pragma Import_Function @@ -4305,7 +4324,7 @@ notation. If the mechanism is not specified, the default mechanism is used. @node Pragma Import_Object,Pragma Import_Procedure,Pragma Import_Function,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{78} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{79} @section Pragma Import_Object @@ -4331,7 +4350,7 @@ point of view). @code{size} is syntax checked, but otherwise ignored by GNAT. @node Pragma Import_Procedure,Pragma Import_Valued_Procedure,Pragma Import_Object,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{79} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{7a} @section Pragma Import_Procedure @@ -4371,7 +4390,7 @@ applies to a procedure rather than a function and the parameters @code{Result_Type} and @code{Result_Mechanism} are not permitted. @node Pragma Import_Valued_Procedure,Pragma Independent,Pragma Import_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{7a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{7b} @section Pragma Import_Valued_Procedure @@ -4424,7 +4443,7 @@ pragma Import that specifies the desired convention, since otherwise the default convention is Ada, which is almost certainly not what is required. @node Pragma Independent,Pragma Independent_Components,Pragma Import_Valued_Procedure,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{7b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{7c} @section Pragma Independent @@ -4446,7 +4465,7 @@ constraints on the representation of the object (for instance prohibiting tight packing). @node Pragma Independent_Components,Pragma Initial_Condition,Pragma Independent,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{7c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{7d} @section Pragma Independent_Components @@ -4467,7 +4486,7 @@ constraints on the representation of the object (for instance prohibiting tight packing). @node Pragma Initial_Condition,Pragma Initialize_Scalars,Pragma Independent_Components,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{7d}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{7e} +@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{7e}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{7f} @section Pragma Initial_Condition @@ -4481,7 +4500,7 @@ For the semantics of this pragma, see the entry for aspect @code{Initial_Conditi in the SPARK 2014 Reference Manual, section 7.1.6. @node Pragma Initialize_Scalars,Pragma Initializes,Pragma Initial_Condition,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{7f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{80} @section Pragma Initialize_Scalars @@ -4590,7 +4609,7 @@ good idea to turn on stack checking (see description of stack checking in the GNAT User’s Guide) when using this pragma. @node Pragma Initializes,Pragma Inline_Always,Pragma Initialize_Scalars,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{80}@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{81} +@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{81}@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{82} @section Pragma Initializes @@ -4617,7 +4636,7 @@ For the semantics of this pragma, see the entry for aspect @code{Initializes} in SPARK 2014 Reference Manual, section 7.1.5. @node Pragma Inline_Always,Pragma Inline_Generic,Pragma Initializes,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{82}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{83} +@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{83}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{84} @section Pragma Inline_Always @@ -4636,7 +4655,7 @@ apply this pragma to a primitive operation of a tagged type. Thanks to such restrictions, the compiler is allowed to remove the out-of-line body of @code{NAME}. @node Pragma Inline_Generic,Pragma Interface,Pragma Inline_Always,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{84} +@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{85} @section Pragma Inline_Generic @@ -4654,7 +4673,7 @@ than to check that the given names are all names of generic units or generic instances. @node Pragma Interface,Pragma Interface_Name,Pragma Inline_Generic,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{85} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{86} @section Pragma Interface @@ -4681,7 +4700,7 @@ maintaining Ada 83/Ada 95 compatibility and is compatible with other Ada 83 compilers. @node Pragma Interface_Name,Pragma Interrupt_Handler,Pragma Interface,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{86} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{87} @section Pragma Interface_Name @@ -4700,7 +4719,7 @@ for an interfaced subprogram, and is provided for compatibility with Ada least one of @code{External_Name} or @code{Link_Name}. @node Pragma Interrupt_Handler,Pragma Interrupt_State,Pragma Interface_Name,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{87} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{88} @section Pragma Interrupt_Handler @@ -4714,7 +4733,7 @@ This program unit pragma is supported for parameterless protected procedures as described in Annex C of the Ada Reference Manual. @node Pragma Interrupt_State,Pragma Invariant,Pragma Interrupt_Handler,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{88} +@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{89} @section Pragma Interrupt_State @@ -4800,7 +4819,7 @@ with an application’s runtime behavior in the cases of the synchronous signals and in the case of the signal used to implement the @code{abort} statement. @node Pragma Invariant,Pragma Keep_Names,Pragma Interrupt_State,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{89}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8a} +@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{8a}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{8b} @section Pragma Invariant @@ -4839,7 +4858,7 @@ For further details on the use of this pragma, see the Ada 2012 documentation of the Type_Invariant aspect. @node Pragma Keep_Names,Pragma License,Pragma Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{8b} +@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{8c} @section Pragma Keep_Names @@ -4859,7 +4878,7 @@ use a @code{Discard_Names} pragma in the @code{gnat.adc} file, but you want to retain the names for specific enumeration types. @node Pragma License,Pragma Link_With,Pragma Keep_Names,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{8c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{8d} @section Pragma License @@ -4954,7 +4973,7 @@ GPL, but no warning for @code{GNAT.Sockets} which is part of the GNAT run time, and is therefore licensed under the modified GPL. @node Pragma Link_With,Pragma Linker_Alias,Pragma License,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{8d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{8e} @section Pragma Link_With @@ -4978,7 +4997,7 @@ separate arguments to the linker. In addition pragma Link_With allows multiple arguments, with the same effect as successive pragmas. @node Pragma Linker_Alias,Pragma Linker_Constructor,Pragma Link_With,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{8e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{8f} @section Pragma Linker_Alias @@ -5019,7 +5038,7 @@ end p; @end example @node Pragma Linker_Constructor,Pragma Linker_Destructor,Pragma Linker_Alias,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{8f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{90} @section Pragma Linker_Constructor @@ -5049,7 +5068,7 @@ listed above. Where possible, the use of Stand Alone Libraries is preferable to the use of this pragma. @node Pragma Linker_Destructor,Pragma Linker_Section,Pragma Linker_Constructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{90} +@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{91} @section Pragma Linker_Destructor @@ -5072,7 +5091,7 @@ See @code{pragma Linker_Constructor} for the set of restrictions that apply because of these specific contexts. @node Pragma Linker_Section,Pragma Lock_Free,Pragma Linker_Destructor,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{91}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{92} +@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{92}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{93} @section Pragma Linker_Section @@ -5146,7 +5165,7 @@ end IO_Card; @end example @node Pragma Lock_Free,Pragma Loop_Invariant,Pragma Linker_Section,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{93}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{94} +@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{94}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{95} @section Pragma Lock_Free @@ -5198,7 +5217,7 @@ Function calls and attribute references must be static @end itemize @node Pragma Loop_Invariant,Pragma Loop_Optimize,Pragma Lock_Free,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{95} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{96} @section Pragma Loop_Invariant @@ -5231,7 +5250,7 @@ attribute can only be used within the expression of a @code{Loop_Invariant} pragma. For full details, see documentation of attribute @code{Loop_Entry}. @node Pragma Loop_Optimize,Pragma Loop_Variant,Pragma Loop_Invariant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{96} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{97} @section Pragma Loop_Optimize @@ -5293,7 +5312,7 @@ compiler in order to enable the relevant optimizations, that is to say vectorization. @node Pragma Loop_Variant,Pragma Machine_Attribute,Pragma Loop_Optimize,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{97} +@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{98} @section Pragma Loop_Variant @@ -5340,7 +5359,7 @@ The @code{Loop_Entry} attribute may be used within the expressions of the @code{Loop_Variant} pragma to refer to values on entry to the loop. @node Pragma Machine_Attribute,Pragma Main,Pragma Loop_Variant,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{98} +@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{99} @section Pragma Machine_Attribute @@ -5366,7 +5385,7 @@ which may make this pragma unusable for some attributes. For further information see @cite{GNU Compiler Collection (GCC) Internals}. @node Pragma Main,Pragma Main_Storage,Pragma Machine_Attribute,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{99} +@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{9a} @section Pragma Main @@ -5386,7 +5405,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has no effect in GNAT, other than being syntax checked. @node Pragma Main_Storage,Pragma Max_Queue_Length,Pragma Main,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{9a} +@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{9b} @section Pragma Main_Storage @@ -5405,7 +5424,7 @@ This pragma is provided for compatibility with OpenVMS VAX Systems. It has no effect in GNAT, other than being syntax checked. @node Pragma Max_Queue_Length,Pragma No_Body,Pragma Main_Storage,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{9b}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{9c} +@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{9c}@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{9d} @section Pragma Max_Queue_Length @@ -5423,7 +5442,7 @@ entry. A value of -1 represents no additional restriction on queue length. @node Pragma No_Body,Pragma No_Caching,Pragma Max_Queue_Length,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{9d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{9e} @section Pragma No_Body @@ -5446,7 +5465,7 @@ dummy body with a No_Body pragma ensures that there is no interference from earlier versions of the package body. @node Pragma No_Caching,Pragma No_Component_Reordering,Pragma No_Body,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{9e}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-caching}@anchor{9f} +@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{9f}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-caching}@anchor{a0} @section Pragma No_Caching @@ -5460,7 +5479,7 @@ For the semantics of this pragma, see the entry for aspect @code{No_Caching} in the SPARK 2014 Reference Manual, section 7.1.2. @node Pragma No_Component_Reordering,Pragma No_Elaboration_Code_All,Pragma No_Caching,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-component-reordering}@anchor{a0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-component-reordering}@anchor{a1} @section Pragma No_Component_Reordering @@ -5479,7 +5498,7 @@ declared in units to which the pragma applies and there is a requirement that this pragma be used consistently within a partition. @node Pragma No_Elaboration_Code_All,Pragma No_Heap_Finalization,Pragma No_Component_Reordering,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a1}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a2} +@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a2}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{a3} @section Pragma No_Elaboration_Code_All @@ -5498,7 +5517,7 @@ current unit, it must also have the No_Elaboration_Code_All aspect set. It may be applied to package or subprogram specs or their generic versions. @node Pragma No_Heap_Finalization,Pragma No_Inline,Pragma No_Elaboration_Code_All,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-heap-finalization}@anchor{a3} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-heap-finalization}@anchor{a4} @section Pragma No_Heap_Finalization @@ -5530,7 +5549,7 @@ lose its @code{No_Heap_Finalization} pragma when the corresponding instance does appear at the library level. @node Pragma No_Inline,Pragma No_Return,Pragma No_Heap_Finalization,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{a4}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a5} +@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{a5}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{a6} @section Pragma No_Inline @@ -5548,7 +5567,7 @@ in particular it is not subject to the use of option @emph{-gnatn} or pragma @code{Inline_Always} for the same @code{NAME}. @node Pragma No_Return,Pragma No_Strict_Aliasing,Pragma No_Inline,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{a6} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{a7} @section Pragma No_Return @@ -5575,7 +5594,7 @@ available in all earlier versions of Ada as an implementation-defined pragma. @node Pragma No_Strict_Aliasing,Pragma No_Tagged_Streams,Pragma No_Return,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{a7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{a8} @section Pragma No_Strict_Aliasing @@ -5597,7 +5616,7 @@ in the @cite{GNAT User’s Guide}. This pragma currently has no effects on access to unconstrained array types. @node Pragma No_Tagged_Streams,Pragma Normalize_Scalars,Pragma No_Strict_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{a8}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{a9} +@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{a9}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{aa} @section Pragma No_Tagged_Streams @@ -5636,7 +5655,7 @@ with empty strings. This is useful to avoid exposing entity names at binary level but has a negative impact on the debuggability of tagged types. @node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{aa} +@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{ab} @section Pragma Normalize_Scalars @@ -5718,7 +5737,7 @@ will always generate an invalid value if one exists. @end table @node Pragma Obsolescent,Pragma Optimize_Alignment,Pragma Normalize_Scalars,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{ab}@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{ac} +@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{ac}@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{ad} @section Pragma Obsolescent @@ -5814,7 +5833,7 @@ So if you specify @code{Entity =>} for the @code{Entity} argument, and a @code{M argument is present, it must be preceded by @code{Message =>}. @node Pragma Optimize_Alignment,Pragma Ordered,Pragma Obsolescent,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{ad} +@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{ae} @section Pragma Optimize_Alignment @@ -5900,7 +5919,7 @@ latter are compiled by default in pragma Optimize_Alignment (Off) mode if no pragma appears at the start of the file. @node Pragma Ordered,Pragma Overflow_Mode,Pragma Optimize_Alignment,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{ae} +@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{af} @section Pragma Ordered @@ -5992,7 +6011,7 @@ For additional information please refer to the description of the @emph{-gnatw.u} switch in the GNAT User’s Guide. @node Pragma Overflow_Mode,Pragma Overriding_Renamings,Pragma Ordered,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{af} +@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{b0} @section Pragma Overflow_Mode @@ -6031,7 +6050,7 @@ The pragma @code{Unsuppress (Overflow_Check)} unsuppresses (enables) overflow checking, but does not affect the overflow mode. @node Pragma Overriding_Renamings,Pragma Partition_Elaboration_Policy,Pragma Overflow_Mode,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{b0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{b1} @section Pragma Overriding_Renamings @@ -6066,7 +6085,7 @@ RM 8.3 (15) stipulates that an overridden operation is not visible within the declaration of the overriding operation. @node Pragma Partition_Elaboration_Policy,Pragma Part_Of,Pragma Overriding_Renamings,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{b1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{b2} @section Pragma Partition_Elaboration_Policy @@ -6083,7 +6102,7 @@ versions of Ada as an implementation-defined pragma. See Ada 2012 Reference Manual for details. @node Pragma Part_Of,Pragma Passive,Pragma Partition_Elaboration_Policy,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{b2}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b3} +@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{b3}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{b4} @section Pragma Part_Of @@ -6099,7 +6118,7 @@ For the semantics of this pragma, see the entry for aspect @code{Part_Of} in the SPARK 2014 Reference Manual, section 7.2.6. @node Pragma Passive,Pragma Persistent_BSS,Pragma Part_Of,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{b4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{b5} @section Pragma Passive @@ -6123,7 +6142,7 @@ 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 Post,Pragma Passive,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b5}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b6} +@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{b6}@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{b7} @section Pragma Persistent_BSS @@ -6154,7 +6173,7 @@ 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 Post,Pragma Postcondition,Pragma Persistent_BSS,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b8} @section Pragma Post @@ -6179,7 +6198,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{b8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{b9} @section Pragma Postcondition @@ -6343,8 +6362,8 @@ use of the pragma identifier @code{Check}. Historically, pragma 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{b9} +@node Pragma Post_Class,Pragma Pre,Pragma Postcondition,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{ba} @section Pragma Post_Class @@ -6378,46 +6397,7 @@ aspects, but is prepared to ignore the pragmas. The assertion 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{ba} -@section Pragma Rename_Pragma - - -@geindex Pragmas -@geindex synonyms - -Syntax: - -@example -pragma Rename_Pragma ( - [New_Name =>] IDENTIFIER, - [Renamed =>] pragma_IDENTIFIER); -@end example - -This pragma provides a mechanism for supplying new names for existing -pragmas. The @code{New_Name} identifier can subsequently be used as a synonym for -the Renamed pragma. For example, suppose you have code that was originally -developed on a compiler that supports Inline_Only as an implementation defined -pragma. And suppose the semantics of pragma Inline_Only are identical to (or at -least very similar to) the GNAT implementation defined pragma -Inline_Always. You could globally replace Inline_Only with Inline_Always. - -However, to avoid that source modification, you could instead add a -configuration pragma: - -@example -pragma Rename_Pragma ( - New_Name => Inline_Only, - Renamed => Inline_Always); -@end example - -Then GNAT will treat “pragma Inline_Only …” as if you had written -“pragma Inline_Always …”. - -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 +@node Pragma Pre,Pragma Precondition,Pragma Post_Class,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{bb} @section Pragma Pre @@ -7246,7 +7226,7 @@ This pragma is standard in Ada 2005, but is available in all earlier 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 +@node Pragma Remote_Access_Type,Pragma Rename_Pragma,Pragma Relative_Deadline,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{d6}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d7} @section Pragma Remote_Access_Type @@ -7272,8 +7252,47 @@ In the generic unit, the formal type is subject to all restrictions 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{d8} +@node Pragma Rename_Pragma,Pragma Restricted_Run_Time,Pragma Remote_Access_Type,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{d8} +@section Pragma Rename_Pragma + + +@geindex Pragmas +@geindex synonyms + +Syntax: + +@example +pragma Rename_Pragma ( + [New_Name =>] IDENTIFIER, + [Renamed =>] pragma_IDENTIFIER); +@end example + +This pragma provides a mechanism for supplying new names for existing +pragmas. The @code{New_Name} identifier can subsequently be used as a synonym for +the Renamed pragma. For example, suppose you have code that was originally +developed on a compiler that supports Inline_Only as an implementation defined +pragma. And suppose the semantics of pragma Inline_Only are identical to (or at +least very similar to) the GNAT implementation defined pragma +Inline_Always. You could globally replace Inline_Only with Inline_Always. + +However, to avoid that source modification, you could instead add a +configuration pragma: + +@example +pragma Rename_Pragma ( + New_Name => Inline_Only, + Renamed => Inline_Always); +@end example + +Then GNAT will treat “pragma Inline_Only …” as if you had written +“pragma Inline_Always …”. + +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 Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Rename_Pragma,Implementation Defined Pragmas +@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{d9} @section Pragma Restricted_Run_Time @@ -7294,7 +7313,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{d9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{da} @section Pragma Restriction_Warnings @@ -7332,7 +7351,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{da} +@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{db} @section Pragma Reviewable @@ -7436,7 +7455,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{db}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{dc} +@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 @@ -7472,7 +7491,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{dd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{de} @section Pragma Share_Generic @@ -7490,7 +7509,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{de}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{df} +@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{df}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{e0} @section Pragma Shared @@ -7498,7 +7517,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{e0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{e1} @section Pragma Short_Circuit_And_Or @@ -7517,7 +7536,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{e1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{e2} @section Pragma Short_Descriptors @@ -7531,7 +7550,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 id39}@anchor{e2}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e3} +@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e3}@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{e4} @section Pragma Simple_Storage_Pool_Type @@ -7585,7 +7604,7 @@ storage-management discipline). An object of a simple storage pool type can be associated with an access type by specifying the attribute -@ref{e4,,Simple_Storage_Pool}. For example: +@ref{e5,,Simple_Storage_Pool}. For example: @example My_Pool : My_Simple_Storage_Pool_Type; @@ -7595,11 +7614,11 @@ type Acc is access My_Data_Type; for Acc'Simple_Storage_Pool use My_Pool; @end example -See attribute @ref{e4,,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 id40}@anchor{e5}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e6} +@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{e6}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e7} @section Pragma Source_File_Name @@ -7691,20 +7710,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{e7,,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 id41}@anchor{e8}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e7} +@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{e9}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e8} @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{e6,,Pragma Source_File_Name}, and +It cannot appear after a @ref{e7,,Pragma Source_File_Name}, and most importantly, once pragma Source_File_Name_Project appears, no further Source_File_Name pragmas are allowed. @@ -7716,7 +7735,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{e9} +@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{ea} @section Pragma Source_Reference @@ -7740,7 +7759,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 id42}@anchor{ea}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{eb} +@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{eb}@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{ec} @section Pragma SPARK_Mode @@ -7822,7 +7841,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{ec} +@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{ed} @section Pragma Static_Elaboration_Desired @@ -7846,7 +7865,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{ed} +@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{ee} @section Pragma Stream_Convert @@ -7923,7 +7942,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{ee} +@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{ef} @section Pragma Style_Checks @@ -7996,7 +8015,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{ef} +@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{f0} @section Pragma Subtitle @@ -8010,7 +8029,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{f0} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{f1} @section Pragma Suppress @@ -8083,7 +8102,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{f1} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{f2} @section Pragma Suppress_All @@ -8102,7 +8121,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 id43}@anchor{f2}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f3} +@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f3}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{f4} @section Pragma Suppress_Debug_Info @@ -8117,7 +8136,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{f4} +@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{f5} @section Pragma Suppress_Exception_Locations @@ -8140,7 +8159,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{f5}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f6} +@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{f6}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f7} @section Pragma Suppress_Initialization @@ -8185,7 +8204,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{f7} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{f8} @section Pragma Task_Name @@ -8241,7 +8260,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{f8} +@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{f9} @section Pragma Task_Storage @@ -8261,7 +8280,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 id45}@anchor{f9}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fa} +@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{fa}@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{fb} @section Pragma Test_Case @@ -8317,7 +8336,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 id46}@anchor{fb}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{fc} +@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{fc}@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{fd} @section Pragma Thread_Local_Storage @@ -8355,7 +8374,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{fd} +@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{fe} @section Pragma Time_Slice @@ -8371,7 +8390,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{fe} +@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{ff} @section Pragma Title @@ -8396,7 +8415,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{ff} +@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{100} @section Pragma Type_Invariant @@ -8417,7 +8436,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{100}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{101} +@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 @@ -8444,7 +8463,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{102} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{103} @section Pragma Unchecked_Union @@ -8464,7 +8483,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{103} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{104} @section Pragma Unevaluated_Use_Of_Old @@ -8519,7 +8538,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{104} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{105} @section Pragma Unimplemented_Unit @@ -8539,7 +8558,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 Unmodified,Pragma Unimplemented_Unit,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{105}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{106} +@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{106}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{107} @section Pragma Universal_Aliasing @@ -8558,7 +8577,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 Unmodified,Pragma Unreferenced,Pragma Universal_Aliasing,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{107}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{108} +@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{108}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{109} @section Pragma Unmodified @@ -8592,7 +8611,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 id50}@anchor{109}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10a} +@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{10a}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{10b} @section Pragma Unreferenced @@ -8636,7 +8655,7 @@ Note that if a warning is desired for all calls to a given subprogram, regardless of whether they occur in the same unit as the subprogram declaration, then this pragma should not be used (calls from another unit would not be flagged); pragma Obsolescent can be used instead -for this purpose, see @ref{ac,,Pragma Obsolescent}. +for this purpose, see @ref{ad,,Pragma Obsolescent}. The second form of pragma @code{Unreferenced} is used within a context clause. In this case the arguments must be unit names of units previously @@ -8652,7 +8671,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 id51}@anchor{10b}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10c} +@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{10c}@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{10d} @section Pragma Unreferenced_Objects @@ -8677,7 +8696,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{10d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{10e} @section Pragma Unreserve_All_Interrupts @@ -8713,7 +8732,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{10e} +@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{10f} @section Pragma Unsuppress @@ -8749,7 +8768,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{10f} +@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{110} @section Pragma Use_VADS_Size @@ -8773,7 +8792,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 id52}@anchor{110}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{111} +@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{111}@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{112} @section Pragma Unused @@ -8807,7 +8826,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{112} +@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{113} @section Pragma Validity_Checks @@ -8863,7 +8882,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 id53}@anchor{113}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{114} +@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{114}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{115} @section Pragma Volatile @@ -8881,7 +8900,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 id54}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{116} +@anchor{gnat_rm/implementation_defined_pragmas id54}@anchor{116}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{117} @section Pragma Volatile_Full_Access @@ -8907,7 +8926,7 @@ is not to the whole object; the compiler is allowed (and generally will) access only part of the object in this case. @node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas -@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{117}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{118} +@anchor{gnat_rm/implementation_defined_pragmas id55}@anchor{118}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{119} @section Pragma Volatile_Function @@ -8921,7 +8940,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{119} +@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{11a} @section Pragma Warning_As_Error @@ -8961,7 +8980,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{11a,,Pragma Warnings}. +warnings provided by the back end and mentioned in @ref{11b,,Pragma Warnings}. By using a single full @emph{-Wxxx} switch in the pragma, such warnings can also be treated as errors. @@ -9011,7 +9030,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 id56}@anchor{11b}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11a} +@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11c}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{11b} @section Pragma Warnings @@ -9167,7 +9186,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{11c} +@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{11d} @section Pragma Weak_External @@ -9218,7 +9237,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{11d} +@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{11e} @section Pragma Wide_Character_Encoding @@ -9249,7 +9268,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 doc}@anchor{11e}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{11f}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{120} +@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{11f}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{120}@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{121} @chapter Implementation Defined Aspects @@ -9369,16 +9388,16 @@ 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{121} +@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{122} @section Aspect Abstract_State @geindex Abstract_State -This aspect is equivalent to @ref{1d,,pragma Abstract_State}. +This aspect is equivalent to @ref{1e,,pragma Abstract_State}. @node Aspect Annotate,Aspect Async_Readers,Aspect Abstract_State,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{122} +@anchor{gnat_rm/implementation_defined_aspects aspect-annotate}@anchor{123} @section Aspect Annotate @@ -9386,7 +9405,7 @@ This aspect is equivalent to @ref{1d,,pragma Abstract_State}. There are three forms of this aspect (where ID is an identifier, and ARG is a general expression), -corresponding to @ref{27,,pragma Annotate}. +corresponding to @ref{28,,pragma Annotate}. @table @asis @@ -9405,63 +9424,63 @@ 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{123} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{124} @section Aspect Async_Readers @geindex Async_Readers -This boolean aspect is equivalent to @ref{2e,,pragma Async_Readers}. +This boolean aspect is equivalent to @ref{2f,,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{124} +@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{125} @section Aspect Async_Writers @geindex Async_Writers -This boolean aspect is equivalent to @ref{30,,pragma Async_Writers}. +This boolean aspect is equivalent to @ref{31,,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{125} +@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{126} @section Aspect Constant_After_Elaboration @geindex Constant_After_Elaboration -This aspect is equivalent to @ref{42,,pragma Constant_After_Elaboration}. +This aspect is equivalent to @ref{43,,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{126} +@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{127} @section Aspect Contract_Cases @geindex Contract_Cases -This aspect is equivalent to @ref{44,,pragma Contract_Cases}, the sequence +This aspect is equivalent to @ref{45,,pragma Contract_Cases}, the sequence 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{127} +@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{128} @section Aspect Depends @geindex Depends -This aspect is equivalent to @ref{54,,pragma Depends}. +This aspect is equivalent to @ref{55,,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{128} +@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{129} @section Aspect Default_Initial_Condition @geindex Default_Initial_Condition -This aspect is equivalent to @ref{4e,,pragma Default_Initial_Condition}. +This aspect is equivalent to @ref{4f,,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{129} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{12a} @section Aspect Dimension @@ -9497,7 +9516,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{12a} +@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{12b} @section Aspect Dimension_System @@ -9557,7 +9576,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{12b} +@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{12c} @section Aspect Disable_Controlled @@ -9570,110 +9589,110 @@ 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{12c} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{12d} @section Aspect Effective_Reads @geindex Effective_Reads -This aspect is equivalent to @ref{59,,pragma Effective_Reads}. +This aspect is equivalent to @ref{5a,,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{12d} +@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{12e} @section Aspect Effective_Writes @geindex Effective_Writes -This aspect is equivalent to @ref{5b,,pragma Effective_Writes}. +This aspect is equivalent to @ref{5c,,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{12e} +@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{12f} @section Aspect Extensions_Visible @geindex Extensions_Visible -This aspect is equivalent to @ref{66,,pragma Extensions_Visible}. +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{12f} +@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{130} @section Aspect Favor_Top_Level @geindex Favor_Top_Level -This boolean aspect is equivalent to @ref{6b,,pragma Favor_Top_Level}. +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{130} +@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{131} @section Aspect Ghost @geindex Ghost -This aspect is equivalent to @ref{6f,,pragma Ghost}. +This aspect is equivalent to @ref{70,,pragma Ghost}. @node Aspect Global,Aspect Initial_Condition,Aspect Ghost,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{131} +@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{132} @section Aspect Global @geindex Global -This aspect is equivalent to @ref{71,,pragma Global}. +This aspect is equivalent to @ref{72,,pragma Global}. @node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{132} +@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{133} @section Aspect Initial_Condition @geindex Initial_Condition -This aspect is equivalent to @ref{7e,,pragma Initial_Condition}. +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{133} +@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{134} @section Aspect Initializes @geindex Initializes -This aspect is equivalent to @ref{81,,pragma Initializes}. +This aspect is equivalent to @ref{82,,pragma Initializes}. @node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{134} +@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{135} @section Aspect Inline_Always @geindex Inline_Always -This boolean aspect is equivalent to @ref{83,,pragma Inline_Always}. +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{135} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{136} @section Aspect Invariant @geindex Invariant -This aspect is equivalent to @ref{8a,,pragma Invariant}. It is a +This aspect is equivalent to @ref{8b,,pragma Invariant}. It is a 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{136} +@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{137} @section Aspect Invariant’Class @geindex Invariant'Class -This aspect is equivalent to @ref{101,,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{137} +@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{138} @section Aspect Iterable @@ -9753,73 +9772,73 @@ 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{138} +@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{139} @section Aspect Linker_Section @geindex Linker_Section -This aspect is equivalent to @ref{92,,pragma Linker_Section}. +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{139} +@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{13a} @section Aspect Lock_Free @geindex Lock_Free -This boolean aspect is equivalent to @ref{94,,pragma Lock_Free}. +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{13a} +@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{13b} @section Aspect Max_Queue_Length @geindex Max_Queue_Length -This aspect is equivalent to @ref{9c,,pragma Max_Queue_Length}. +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{13b} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-caching}@anchor{13c} @section Aspect No_Caching @geindex No_Caching -This boolean aspect is equivalent to @ref{9f,,pragma No_Caching}. +This boolean aspect is equivalent to @ref{a0,,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{13c} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{13d} @section Aspect No_Elaboration_Code_All @geindex No_Elaboration_Code_All -This aspect is equivalent to @ref{a2,,pragma No_Elaboration_Code_All} +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{13d} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-inline}@anchor{13e} @section Aspect No_Inline @geindex No_Inline -This boolean aspect is equivalent to @ref{a5,,pragma No_Inline}. +This boolean aspect is equivalent to @ref{a6,,pragma No_Inline}. @node Aspect No_Tagged_Streams,Aspect No_Task_Parts,Aspect No_Inline,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{13e} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{13f} @section Aspect No_Tagged_Streams @geindex No_Tagged_Streams -This aspect is equivalent to @ref{a9,,pragma No_Tagged_Streams} with an +This aspect is equivalent to @ref{aa,,pragma No_Tagged_Streams} with an argument specifying a root tagged type (thus this aspect can only be applied to such a type). @node Aspect No_Task_Parts,Aspect Object_Size,Aspect No_Tagged_Streams,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{13f} +@anchor{gnat_rm/implementation_defined_aspects aspect-no-task-parts}@anchor{140} @section Aspect No_Task_Parts @@ -9835,45 +9854,45 @@ away certain tasking-related code that would otherwise be needed for T’Class, because descendants of T might contain tasks. @node Aspect Object_Size,Aspect Obsolescent,Aspect No_Task_Parts,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{140} +@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{141} @section Aspect Object_Size @geindex Object_Size -This aspect is equivalent to @ref{141,,attribute Object_Size}. +This aspect is equivalent to @ref{142,,attribute Object_Size}. @node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{142} +@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{143} @section Aspect Obsolescent @geindex Obsolsecent -This aspect is equivalent to @ref{ac,,pragma Obsolescent}. Note that the +This aspect is equivalent to @ref{ad,,pragma Obsolescent}. Note that the 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{143} +@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{144} @section Aspect Part_Of @geindex Part_Of -This aspect is equivalent to @ref{b3,,pragma Part_Of}. +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{144} +@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{145} @section Aspect Persistent_BSS @geindex Persistent_BSS -This boolean aspect is equivalent to @ref{b6,,pragma Persistent_BSS}. +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{145} +@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{146} @section Aspect Predicate @@ -9887,7 +9906,7 @@ 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{146} +@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{147} @section Aspect Pure_Function @@ -9896,7 +9915,7 @@ expression. It is also separately controllable using pragma 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{147} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{148} @section Aspect Refined_Depends @@ -9905,7 +9924,7 @@ This boolean aspect is equivalent to @ref{ca,,pragma Pure_Function}. 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{148} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{149} @section Aspect Refined_Global @@ -9914,7 +9933,7 @@ This aspect is equivalent to @ref{ce,,pragma Refined_Depends}. 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{149} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{14a} @section Aspect Refined_Post @@ -9923,7 +9942,7 @@ This aspect is equivalent to @ref{d0,,pragma Refined_Global}. 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{14a} +@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{14b} @section Aspect Refined_State @@ -9932,7 +9951,7 @@ This aspect is equivalent to @ref{d2,,pragma Refined_Post}. 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{14b} +@anchor{gnat_rm/implementation_defined_aspects aspect-relaxed-initialization}@anchor{14c} @section Aspect Relaxed_Initialization @@ -9942,7 +9961,7 @@ 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{14c} +@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{14d} @section Aspect Remote_Access_Type @@ -9951,178 +9970,178 @@ Manual, section 6.10. This aspect is equivalent to @ref{d7,,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{14d} +@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{14e} @section Aspect Secondary_Stack_Size @geindex Secondary_Stack_Size -This aspect is equivalent to @ref{dc,,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{14e} +@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{14f} @section Aspect Scalar_Storage_Order @geindex Scalar_Storage_Order -This aspect is equivalent to a @ref{14f,,attribute Scalar_Storage_Order}. +This aspect is equivalent to a @ref{150,,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{150} +@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{151} @section Aspect Shared @geindex Shared -This boolean aspect is equivalent to @ref{df,,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{151} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{152} @section Aspect Simple_Storage_Pool @geindex Simple_Storage_Pool -This aspect is equivalent to @ref{e4,,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{152} +@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{153} @section Aspect Simple_Storage_Pool_Type @geindex Simple_Storage_Pool_Type -This boolean aspect is equivalent to @ref{e3,,pragma Simple_Storage_Pool_Type}. +This boolean aspect is equivalent to @ref{e4,,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{153} +@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{154} @section Aspect SPARK_Mode @geindex SPARK_Mode -This aspect is equivalent to @ref{eb,,pragma SPARK_Mode} and +This aspect is equivalent to @ref{ec,,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{154} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{155} @section Aspect Suppress_Debug_Info @geindex Suppress_Debug_Info -This boolean aspect is equivalent to @ref{f3,,pragma Suppress_Debug_Info}. +This boolean aspect is equivalent to @ref{f4,,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{155} +@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{156} @section Aspect Suppress_Initialization @geindex Suppress_Initialization -This boolean aspect is equivalent to @ref{f6,,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{156} +@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{157} @section Aspect Test_Case @geindex Test_Case -This aspect is equivalent to @ref{fa,,pragma Test_Case}. +This aspect is equivalent to @ref{fb,,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{157} +@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{158} @section Aspect Thread_Local_Storage @geindex Thread_Local_Storage -This boolean aspect is equivalent to @ref{fc,,pragma Thread_Local_Storage}. +This boolean aspect is equivalent to @ref{fd,,pragma Thread_Local_Storage}. @node Aspect Universal_Aliasing,Aspect Unmodified,Aspect Thread_Local_Storage,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{158} +@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{159} @section Aspect Universal_Aliasing @geindex Universal_Aliasing -This boolean aspect is equivalent to @ref{106,,pragma Universal_Aliasing}. +This boolean aspect is equivalent to @ref{107,,pragma Universal_Aliasing}. @node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Aliasing,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{159} +@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{15a} @section Aspect Unmodified @geindex Unmodified -This boolean aspect is equivalent to @ref{108,,pragma Unmodified}. +This boolean aspect is equivalent to @ref{109,,pragma Unmodified}. @node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15a} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{15b} @section Aspect Unreferenced @geindex Unreferenced -This boolean aspect is equivalent to @ref{10a,,pragma Unreferenced}. +This boolean aspect is equivalent to @ref{10b,,pragma Unreferenced}. When using the @code{-gnat2022} 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{15b} +@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{15c} @section Aspect Unreferenced_Objects @geindex Unreferenced_Objects -This boolean aspect is equivalent to @ref{10c,,pragma Unreferenced_Objects}. +This boolean aspect is equivalent to @ref{10d,,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{15c} +@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{15d} @section Aspect Value_Size @geindex Value_Size -This aspect is equivalent to @ref{15d,,attribute Value_Size}. +This aspect is equivalent to @ref{15e,,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{15e} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{15f} @section Aspect Volatile_Full_Access @geindex Volatile_Full_Access -This boolean aspect is equivalent to @ref{116,,pragma Volatile_Full_Access}. +This boolean aspect is equivalent to @ref{117,,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{15f} +@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{160} @section Aspect Volatile_Function @geindex Volatile_Function -This boolean aspect is equivalent to @ref{118,,pragma Volatile_Function}. +This boolean aspect is equivalent to @ref{119,,pragma Volatile_Function}. @node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects -@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{160} +@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{161} @section Aspect Warnings @geindex Warnings -This aspect is equivalent to the two argument form of @ref{11a,,pragma Warnings}, +This aspect is equivalent to the two argument form of @ref{11b,,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{161}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{162}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8} +@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{162}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{163}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8} @chapter Implementation Defined Attributes @@ -10229,7 +10248,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{163} +@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{164} @section Attribute Abort_Signal @@ -10243,7 +10262,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{164} +@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{165} @section Attribute Address_Size @@ -10259,7 +10278,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{165} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{166} @section Attribute Asm_Input @@ -10273,10 +10292,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{166,,Machine Code Insertions} +@ref{167,,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{167} +@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{168} @section Attribute Asm_Output @@ -10292,10 +10311,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{166,,Machine Code Insertions} +@ref{167,,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{168} +@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{169} @section Attribute Atomic_Always_Lock_Free @@ -10307,7 +10326,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{169} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{16a} @section Attribute Bit @@ -10338,7 +10357,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{16a} +@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{16b} @section Attribute Bit_Position @@ -10353,7 +10372,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{16b} +@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{16c} @section Attribute Code_Address @@ -10396,7 +10415,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{16c} +@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{16d} @section Attribute Compiler_Version @@ -10407,7 +10426,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{16d} +@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{16e} @section Attribute Constrained @@ -10422,7 +10441,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{16e} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{16f} @section Attribute Default_Bit_Order @@ -10439,7 +10458,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{16f} +@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{170} @section Attribute Default_Scalar_Storage_Order @@ -10456,7 +10475,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{170} +@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{171} @section Attribute Deref @@ -10469,7 +10488,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{171} +@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{172} @section Attribute Descriptor_Size @@ -10498,7 +10517,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{172} +@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{173} @section Attribute Elaborated @@ -10513,7 +10532,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{173} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{174} @section Attribute Elab_Body @@ -10529,7 +10548,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{174} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{175} @section Attribute Elab_Spec @@ -10545,7 +10564,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{175} +@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{176} @section Attribute Elab_Subp_Body @@ -10559,7 +10578,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{176} +@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{177} @section Attribute Emax @@ -10572,7 +10591,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{177} +@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{178} @section Attribute Enabled @@ -10596,7 +10615,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{178} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{179} @section Attribute Enum_Rep @@ -10636,7 +10655,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{179} +@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{17a} @section Attribute Enum_Val @@ -10662,7 +10681,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{17a} +@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{17b} @section Attribute Epsilon @@ -10675,7 +10694,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{17b} +@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{17c} @section Attribute Fast_Math @@ -10686,7 +10705,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{17c} +@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{17d} @section Attribute Finalization_Size @@ -10704,7 +10723,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{17d} +@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{17e} @section Attribute Fixed_Value @@ -10731,7 +10750,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{17e} +@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{17f} @section Attribute From_Any @@ -10741,7 +10760,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{17f} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{180} @section Attribute Has_Access_Values @@ -10759,7 +10778,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 Has_Tagged_Values,Attribute Has_Access_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{180} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{181} @section Attribute Has_Discriminants @@ -10775,7 +10794,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 Has_Tagged_Values,Attribute Img,Attribute Has_Discriminants,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{181} +@anchor{gnat_rm/implementation_defined_attributes attribute-has-tagged-values}@anchor{182} @section Attribute Has_Tagged_Values @@ -10792,7 +10811,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 Img,Attribute Initialized,Attribute Has_Tagged_Values,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{182} +@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{183} @section Attribute Img @@ -10822,7 +10841,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{183} +@anchor{gnat_rm/implementation_defined_attributes attribute-initialized}@anchor{184} @section Attribute Initialized @@ -10832,7 +10851,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{184} +@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{185} @section Attribute Integer_Value @@ -10860,7 +10879,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{185} +@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{186} @section Attribute Invalid_Value @@ -10874,7 +10893,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{186} +@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{187} @section Attribute Iterable @@ -10883,7 +10902,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{187} +@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{188} @section Attribute Large @@ -10896,7 +10915,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{188} +@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{189} @section Attribute Library_Level @@ -10922,7 +10941,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{189} +@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{18a} @section Attribute Lock_Free @@ -10932,7 +10951,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{18a} +@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18b} @section Attribute Loop_Entry @@ -10962,7 +10981,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{18b} +@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18c} @section Attribute Machine_Size @@ -10972,7 +10991,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{18c} +@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18d} @section Attribute Mantissa @@ -10985,7 +11004,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Maximum_Alignment,Attribute Max_Integer_Size,Attribute Mantissa,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{18d}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18e} +@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{18e}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18f} @section Attribute Maximum_Alignment @@ -11001,7 +11020,7 @@ for an object, guaranteeing that it is properly aligned in all cases. @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{18f} +@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{190} @section Attribute Max_Integer_Size @@ -11012,7 +11031,7 @@ 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{190} +@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{191} @section Attribute Mechanism_Code @@ -11043,7 +11062,7 @@ by reference @end table @node Attribute Null_Parameter,Attribute Object_Size,Attribute Mechanism_Code,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{191} +@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{192} @section Attribute Null_Parameter @@ -11068,7 +11087,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{141}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{192} +@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{142}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{193} @section Attribute Object_Size @@ -11138,7 +11157,7 @@ Similar additional checks are performed in other contexts requiring statically matching subtypes. @node Attribute Old,Attribute Passed_By_Reference,Attribute Object_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{193} +@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{194} @section Attribute Old @@ -11153,7 +11172,7 @@ definition are allowed under control of implementation defined pragma @code{Unevaluated_Use_Of_Old}. @node Attribute Passed_By_Reference,Attribute Pool_Address,Attribute Old,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{194} +@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{195} @section Attribute Passed_By_Reference @@ -11169,7 +11188,7 @@ passed by copy in calls. For scalar types, the result is always @code{False} and is static. For non-scalar types, the result is nonstatic. @node Attribute Pool_Address,Attribute Range_Length,Attribute Passed_By_Reference,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{195} +@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{196} @section Attribute Pool_Address @@ -11191,7 +11210,7 @@ For an object created by @code{new}, @code{Ptr.all'Pool_Address} is what is passed to @code{Allocate} and returned from @code{Deallocate}. @node Attribute Range_Length,Attribute Restriction_Set,Attribute Pool_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{196} +@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{197} @section Attribute Range_Length @@ -11204,7 +11223,7 @@ applied to the index subtype of a one dimensional array always gives the same result as @code{Length} applied to the array itself. @node Attribute Restriction_Set,Attribute Result,Attribute Range_Length,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{197} +@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{198} @section Attribute Restriction_Set @@ -11274,7 +11293,7 @@ Restrictions pragma, they are not analyzed semantically, so they do not have a type. @node Attribute Result,Attribute Safe_Emax,Attribute Restriction_Set,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{198} +@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{199} @section Attribute Result @@ -11287,7 +11306,7 @@ For a further discussion of the use of this attribute and examples of its use, see the description of pragma Postcondition. @node Attribute Safe_Emax,Attribute Safe_Large,Attribute Result,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{199} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{19a} @section Attribute Safe_Emax @@ -11300,7 +11319,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Safe_Large,Attribute Safe_Small,Attribute Safe_Emax,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{19a} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{19b} @section Attribute Safe_Large @@ -11313,7 +11332,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. @node Attribute Safe_Small,Attribute Scalar_Storage_Order,Attribute Safe_Large,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19b} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19c} @section Attribute Safe_Small @@ -11326,7 +11345,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 attribute-scalar-storage-order}@anchor{14f}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19c} +@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{150}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19d} @section Attribute Scalar_Storage_Order @@ -11489,7 +11508,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{e4}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19d} +@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e5}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19e} @section Attribute Simple_Storage_Pool @@ -11552,7 +11571,7 @@ as defined in section 13.11.2 of the Ada Reference Manual, except that the term @emph{simple storage pool} is substituted for @emph{storage pool}. @node Attribute Small,Attribute Small_Denominator,Attribute Simple_Storage_Pool,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{19e} +@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{19f} @section Attribute Small @@ -11568,7 +11587,7 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute when applied to floating-point types. @node Attribute Small_Denominator,Attribute Small_Numerator,Attribute Small,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{19f} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{1a0} @section Attribute Small_Denominator @@ -11581,7 +11600,7 @@ denominator in the representation of @code{typ'Small} as a rational number with coprime factors (i.e. as an irreducible fraction). @node Attribute Small_Numerator,Attribute Storage_Unit,Attribute Small_Denominator,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1a0} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{1a1} @section Attribute Small_Numerator @@ -11594,7 +11613,7 @@ numerator in the representation of @code{typ'Small} as a rational number with coprime factors (i.e. as an irreducible fraction). @node Attribute Storage_Unit,Attribute Stub_Type,Attribute Small_Numerator,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a1} +@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a2} @section Attribute Storage_Unit @@ -11604,7 +11623,7 @@ with coprime factors (i.e. as an irreducible fraction). prefix) provides the same value as @code{System.Storage_Unit}. @node Attribute Stub_Type,Attribute System_Allocator_Alignment,Attribute Storage_Unit,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a2} +@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a3} @section Attribute Stub_Type @@ -11628,7 +11647,7 @@ unit @code{System.Partition_Interface}. Use of this attribute will create an implicit dependency on this unit. @node Attribute System_Allocator_Alignment,Attribute Target_Name,Attribute Stub_Type,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a3} +@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a4} @section Attribute System_Allocator_Alignment @@ -11645,7 +11664,7 @@ with alignment too large or to enable a realignment circuitry if the alignment request is larger than this value. @node Attribute Target_Name,Attribute To_Address,Attribute System_Allocator_Alignment,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a4} +@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a5} @section Attribute Target_Name @@ -11658,7 +11677,7 @@ standard gcc target name without the terminating slash (for example, GNAT 5.0 on windows yields “i586-pc-mingw32msv”). @node Attribute To_Address,Attribute To_Any,Attribute Target_Name,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a5} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a6} @section Attribute To_Address @@ -11681,7 +11700,7 @@ modular manner (e.g., -1 means the same as 16#FFFF_FFFF# on a 32 bits machine). @node Attribute To_Any,Attribute Type_Class,Attribute To_Address,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a6} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a7} @section Attribute To_Any @@ -11691,7 +11710,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Type_Class,Attribute Type_Key,Attribute To_Any,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a7} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a8} @section Attribute Type_Class @@ -11721,7 +11740,7 @@ applies to all concurrent types. This attribute is designed to be compatible with the DEC Ada 83 attribute of the same name. @node Attribute Type_Key,Attribute TypeCode,Attribute Type_Class,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a8} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a9} @section Attribute Type_Key @@ -11733,7 +11752,7 @@ about the type or subtype. This provides improved compatibility with other implementations that support this attribute. @node Attribute TypeCode,Attribute Unconstrained_Array,Attribute Type_Key,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1a9} +@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1aa} @section Attribute TypeCode @@ -11743,7 +11762,7 @@ This internal attribute is used for the generation of remote subprogram stubs in the context of the Distributed Systems Annex. @node Attribute Unconstrained_Array,Attribute Universal_Literal_String,Attribute TypeCode,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1aa} +@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1ab} @section Attribute Unconstrained_Array @@ -11757,7 +11776,7 @@ still static, and yields the result of applying this test to the generic actual. @node Attribute Universal_Literal_String,Attribute Unrestricted_Access,Attribute Unconstrained_Array,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ab} +@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1ac} @section Attribute Universal_Literal_String @@ -11785,7 +11804,7 @@ end; @end example @node Attribute Unrestricted_Access,Attribute Update,Attribute Universal_Literal_String,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ac} +@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ad} @section Attribute Unrestricted_Access @@ -11972,7 +11991,7 @@ In general this is a risky approach. It may appear to “work” but such uses o of GNAT to another, so are best avoided if possible. @node Attribute Update,Attribute Valid_Image,Attribute Unrestricted_Access,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ad} +@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ae} @section Attribute Update @@ -12053,7 +12072,7 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30); which changes element (1,2) to 20 and (3,4) to 30. @node Attribute Valid_Image,Attribute Valid_Scalars,Attribute Update,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-image}@anchor{1ae} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-image}@anchor{1af} @section Attribute Valid_Image @@ -12065,7 +12084,7 @@ a String, and returns Boolean. @code{T'Valid_Image (S)} returns True if and only if @code{T'Value (S)} would not raise Constraint_Error. @node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Image,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1af} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1b0} @section Attribute Valid_Scalars @@ -12099,7 +12118,7 @@ write a function with a single use of the attribute, and then call that function from multiple places. @node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1b0} +@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1b1} @section Attribute VADS_Size @@ -12119,7 +12138,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 attribute-value-size}@anchor{15d}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b1} +@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{15e}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b2} @section Attribute Value_Size @@ -12133,7 +12152,7 @@ a value of the given subtype. It is the same as @code{type'Size}, but, unlike @code{Size}, may be set for non-first subtypes. @node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b2} +@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b3} @section Attribute Wchar_T_Size @@ -12145,7 +12164,7 @@ primarily for constructing the definition of this type in package @code{Interfaces.C}. The result is a static constant. @node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b3} +@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b4} @section Attribute Word_Size @@ -12156,7 +12175,7 @@ prefix) provides the value @code{System.Word_Size}. The result is a static constant. @node Standard and Implementation Defined Restrictions,Implementation Advice,Implementation Defined Attributes,Top -@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1b4}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9} @chapter Standard and Implementation Defined Restrictions @@ -12185,7 +12204,7 @@ language defined or GNAT-specific, are listed in the following. @end menu @node Partition-Wide Restrictions,Program Unit Level Restrictions,,Standard and Implementation Defined Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b7}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b8} @section Partition-Wide Restrictions @@ -12274,7 +12293,7 @@ then all compilation units in the partition must obey the restriction). @end menu @node Immediate_Reclamation,Max_Asynchronous_Select_Nesting,,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b9} @subsection Immediate_Reclamation @@ -12286,7 +12305,7 @@ deallocation, any storage reserved at run time for an object is immediately reclaimed when the object no longer exists. @node Max_Asynchronous_Select_Nesting,Max_Entry_Queue_Length,Immediate_Reclamation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1ba} @subsection Max_Asynchronous_Select_Nesting @@ -12298,7 +12317,7 @@ detected at compile time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node Max_Entry_Queue_Length,Max_Protected_Entries,Max_Asynchronous_Select_Nesting,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1ba} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1bb} @subsection Max_Entry_Queue_Length @@ -12319,7 +12338,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node Max_Protected_Entries,Max_Select_Alternatives,Max_Entry_Queue_Length,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1bb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1bc} @subsection Max_Protected_Entries @@ -12330,7 +12349,7 @@ bounds of every entry family of a protected unit shall be static, or shall be defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Select_Alternatives,Max_Storage_At_Blocking,Max_Protected_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bd} @subsection Max_Select_Alternatives @@ -12339,7 +12358,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. [RM D.7] Specifies the maximum number of alternatives in a selective accept. @node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1be} @subsection Max_Storage_At_Blocking @@ -12350,7 +12369,7 @@ Storage_Size that can be retained by a blocked task. A violation of this restriction causes Storage_Error to be raised. @node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1be} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1bf} @subsection Max_Task_Entries @@ -12363,7 +12382,7 @@ defined by a discriminant of a subtype whose corresponding bound is static. @node Max_Tasks,No_Abort_Statements,Max_Task_Entries,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1bf} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1c0} @subsection Max_Tasks @@ -12376,7 +12395,7 @@ time. Violations of this restriction with values other than zero cause Storage_Error to be raised. @node No_Abort_Statements,No_Access_Parameter_Allocators,Max_Tasks,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1c0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1c1} @subsection No_Abort_Statements @@ -12386,7 +12405,7 @@ Storage_Error to be raised. no calls to Task_Identification.Abort_Task. @node No_Access_Parameter_Allocators,No_Access_Subprograms,No_Abort_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c2} @subsection No_Access_Parameter_Allocators @@ -12397,7 +12416,7 @@ occurrences of an allocator as the actual parameter to an access parameter. @node No_Access_Subprograms,No_Allocators,No_Access_Parameter_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c3} @subsection No_Access_Subprograms @@ -12407,7 +12426,7 @@ parameter. declarations of access-to-subprogram types. @node No_Allocators,No_Anonymous_Allocators,No_Access_Subprograms,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c4} @subsection No_Allocators @@ -12417,7 +12436,7 @@ declarations of access-to-subprogram types. occurrences of an allocator. @node No_Anonymous_Allocators,No_Asynchronous_Control,No_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c5} @subsection No_Anonymous_Allocators @@ -12427,7 +12446,7 @@ occurrences of an allocator. occurrences of an allocator of anonymous access type. @node No_Asynchronous_Control,No_Calendar,No_Anonymous_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c6} @subsection No_Asynchronous_Control @@ -12437,7 +12456,7 @@ occurrences of an allocator of anonymous access type. dependences on the predefined package Asynchronous_Task_Control. @node No_Calendar,No_Coextensions,No_Asynchronous_Control,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c7} @subsection No_Calendar @@ -12447,7 +12466,7 @@ dependences on the predefined package Asynchronous_Task_Control. dependences on package Calendar. @node No_Coextensions,No_Default_Initialization,No_Calendar,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c8} @subsection No_Coextensions @@ -12457,7 +12476,7 @@ dependences on package Calendar. coextensions. See 3.10.2. @node No_Default_Initialization,No_Delay,No_Coextensions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c9} @subsection No_Default_Initialization @@ -12474,7 +12493,7 @@ is to prohibit all cases of variables declared without a specific initializer (including the case of OUT scalar parameters). @node No_Delay,No_Dependence,No_Default_Initialization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1ca} @subsection No_Delay @@ -12484,7 +12503,7 @@ initializer (including the case of OUT scalar parameters). delay statements and no semantic dependences on package Calendar. @node No_Dependence,No_Direct_Boolean_Operators,No_Delay,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1ca} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1cb} @subsection No_Dependence @@ -12494,7 +12513,7 @@ delay statements and no semantic dependences on package Calendar. dependences on a library unit. @node No_Direct_Boolean_Operators,No_Dispatch,No_Dependence,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1cb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1cc} @subsection No_Direct_Boolean_Operators @@ -12507,7 +12526,7 @@ protocol requires the use of short-circuit (and then, or else) forms for all composite boolean operations. @node No_Dispatch,No_Dispatching_Calls,No_Direct_Boolean_Operators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cd} @subsection No_Dispatch @@ -12517,7 +12536,7 @@ composite boolean operations. occurrences of @code{T'Class}, for any (tagged) subtype @code{T}. @node No_Dispatching_Calls,No_Dynamic_Attachment,No_Dispatch,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1ce} @subsection No_Dispatching_Calls @@ -12578,7 +12597,7 @@ end Example; @end example @node No_Dynamic_Attachment,No_Dynamic_Priorities,No_Dispatching_Calls,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1ce} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1cf} @subsection No_Dynamic_Attachment @@ -12597,7 +12616,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node No_Dynamic_Priorities,No_Entry_Calls_In_Elaboration_Code,No_Dynamic_Attachment,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1cf} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1d0} @subsection No_Dynamic_Priorities @@ -12606,7 +12625,7 @@ warnings on obsolescent features are activated). [RM D.7] There are no semantic dependencies on the package Dynamic_Priorities. @node No_Entry_Calls_In_Elaboration_Code,No_Enumeration_Maps,No_Dynamic_Priorities,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1d0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1d1} @subsection No_Entry_Calls_In_Elaboration_Code @@ -12618,7 +12637,7 @@ restriction, the compiler can assume that no code past an accept statement in a task can be executed at elaboration time. @node No_Enumeration_Maps,No_Exception_Handlers,No_Entry_Calls_In_Elaboration_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d2} @subsection No_Enumeration_Maps @@ -12629,7 +12648,7 @@ enumeration maps are used (that is Image and Value attributes applied to enumeration types). @node No_Exception_Handlers,No_Exception_Propagation,No_Enumeration_Maps,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d3} @subsection No_Exception_Handlers @@ -12654,7 +12673,7 @@ statement generated by the compiler). The Line parameter when nonzero represents the line number in the source program where the raise occurs. @node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d4} @subsection No_Exception_Propagation @@ -12671,7 +12690,7 @@ the package GNAT.Current_Exception is not permitted, and reraise statements (raise with no operand) are not permitted. @node No_Exception_Registration,No_Exceptions,No_Exception_Propagation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d5} @subsection No_Exception_Registration @@ -12685,7 +12704,7 @@ code is simplified by omitting the otherwise-required global registration of exceptions when they are declared. @node No_Exceptions,No_Finalization,No_Exception_Registration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d6} @subsection No_Exceptions @@ -12696,7 +12715,7 @@ raise statements and no exception handlers and also suppresses the generation of language-defined run-time checks. @node No_Finalization,No_Fixed_Point,No_Exceptions,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d7} @subsection No_Finalization @@ -12737,7 +12756,7 @@ object or a nested component, either declared on the stack or on the heap. The deallocation of a controlled object no longer finalizes its contents. @node No_Fixed_Point,No_Floating_Point,No_Finalization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d8} @subsection No_Fixed_Point @@ -12747,7 +12766,7 @@ deallocation of a controlled object no longer finalizes its contents. occurrences of fixed point types and operations. @node No_Floating_Point,No_Implicit_Conditionals,No_Fixed_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d9} @subsection No_Floating_Point @@ -12757,7 +12776,7 @@ occurrences of fixed point types and operations. occurrences of floating point types and operations. @node No_Implicit_Conditionals,No_Implicit_Dynamic_Code,No_Floating_Point,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1da} @subsection No_Implicit_Conditionals @@ -12773,7 +12792,7 @@ normal manner. Constructs generating implicit conditionals include comparisons of composite objects and the Max/Min attributes. @node No_Implicit_Dynamic_Code,No_Implicit_Heap_Allocations,No_Implicit_Conditionals,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1da} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1db} @subsection No_Implicit_Dynamic_Code @@ -12803,7 +12822,7 @@ foreign-language convention; primitive operations of nested tagged types. @node No_Implicit_Heap_Allocations,No_Implicit_Protected_Object_Allocations,No_Implicit_Dynamic_Code,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1db} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1dc} @subsection No_Implicit_Heap_Allocations @@ -12812,7 +12831,7 @@ types. [RM D.7] No constructs are allowed to cause implicit heap allocation. @node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1dc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1dd} @subsection No_Implicit_Protected_Object_Allocations @@ -12822,7 +12841,7 @@ types. protected object. @node No_Implicit_Task_Allocations,No_Initialize_Scalars,No_Implicit_Protected_Object_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1de} @subsection No_Implicit_Task_Allocations @@ -12831,7 +12850,7 @@ protected object. [GNAT] No constructs are allowed to cause implicit heap allocation of a task. @node No_Initialize_Scalars,No_IO,No_Implicit_Task_Allocations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1de} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1df} @subsection No_Initialize_Scalars @@ -12843,7 +12862,7 @@ code, and in particular eliminates dummy null initialization routines that are otherwise generated for some record and array types. @node No_IO,No_Local_Allocators,No_Initialize_Scalars,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1df} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1e0} @subsection No_IO @@ -12854,7 +12873,7 @@ dependences on any of the library units Sequential_IO, Direct_IO, Text_IO, Wide_Text_IO, Wide_Wide_Text_IO, or Stream_IO. @node No_Local_Allocators,No_Local_Protected_Objects,No_IO,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1e0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1e1} @subsection No_Local_Allocators @@ -12865,7 +12884,7 @@ occurrences of an allocator in subprograms, generic subprograms, tasks, and entry bodies. @node No_Local_Protected_Objects,No_Local_Timing_Events,No_Local_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e2} @subsection No_Local_Protected_Objects @@ -12875,7 +12894,7 @@ and entry bodies. only declared at the library level. @node No_Local_Timing_Events,No_Long_Long_Integers,No_Local_Protected_Objects,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e3} @subsection No_Local_Timing_Events @@ -12885,7 +12904,7 @@ only declared at the library level. declared at the library level. @node No_Long_Long_Integers,No_Multiple_Elaboration,No_Local_Timing_Events,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e4} @subsection No_Long_Long_Integers @@ -12897,7 +12916,7 @@ implicit base type is Long_Long_Integer, and modular types whose size exceeds Long_Integer’Size. @node No_Multiple_Elaboration,No_Nested_Finalization,No_Long_Long_Integers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e5} @subsection No_Multiple_Elaboration @@ -12913,7 +12932,7 @@ possible, including non-Ada main programs and Stand Alone libraries, are not permitted and will be diagnosed by the binder. @node No_Nested_Finalization,No_Protected_Type_Allocators,No_Multiple_Elaboration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e6} @subsection No_Nested_Finalization @@ -12922,7 +12941,7 @@ permitted and will be diagnosed by the binder. [RM D.7] All objects requiring finalization are declared at the library level. @node No_Protected_Type_Allocators,No_Protected_Types,No_Nested_Finalization,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e7} @subsection No_Protected_Type_Allocators @@ -12932,7 +12951,7 @@ permitted and will be diagnosed by the binder. expressions that attempt to allocate protected objects. @node No_Protected_Types,No_Recursion,No_Protected_Type_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e8} @subsection No_Protected_Types @@ -12942,7 +12961,7 @@ expressions that attempt to allocate protected objects. declarations of protected types or protected objects. @node No_Recursion,No_Reentrancy,No_Protected_Types,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1e8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1e9} @subsection No_Recursion @@ -12952,7 +12971,7 @@ declarations of protected types or protected objects. part of its execution. @node No_Reentrancy,No_Relative_Delay,No_Recursion,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1e9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1ea} @subsection No_Reentrancy @@ -12962,7 +12981,7 @@ part of its execution. two tasks at the same time. @node No_Relative_Delay,No_Requeue_Statements,No_Reentrancy,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1ea} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1eb} @subsection No_Relative_Delay @@ -12973,7 +12992,7 @@ relative statements and prevents expressions such as @code{delay 1.23;} from appearing in source code. @node No_Requeue_Statements,No_Secondary_Stack,No_Relative_Delay,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1eb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1ec} @subsection No_Requeue_Statements @@ -12991,7 +13010,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on oNobsolescent features are activated). @node No_Secondary_Stack,No_Select_Statements,No_Requeue_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1ec} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1ed} @subsection No_Secondary_Stack @@ -13004,7 +13023,7 @@ stack is used to implement functions returning unconstrained objects secondary stacks for tasks (excluding the environment task) at run time. @node No_Select_Statements,No_Specific_Termination_Handlers,No_Secondary_Stack,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ed} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ee} @subsection No_Select_Statements @@ -13014,7 +13033,7 @@ secondary stacks for tasks (excluding the environment task) at run time. kind are permitted, that is the keyword @code{select} may not appear. @node No_Specific_Termination_Handlers,No_Specification_of_Aspect,No_Select_Statements,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1ee} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1ef} @subsection No_Specific_Termination_Handlers @@ -13024,7 +13043,7 @@ kind are permitted, that is the keyword @code{select} may not appear. or to Ada.Task_Termination.Specific_Handler. @node No_Specification_of_Aspect,No_Standard_Allocators_After_Elaboration,No_Specific_Termination_Handlers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1ef} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1f0} @subsection No_Specification_of_Aspect @@ -13035,7 +13054,7 @@ specification, attribute definition clause, or pragma is given for a given aspect. @node No_Standard_Allocators_After_Elaboration,No_Standard_Storage_Pools,No_Specification_of_Aspect,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f1} @subsection No_Standard_Allocators_After_Elaboration @@ -13047,7 +13066,7 @@ library items of the partition has completed. Otherwise, Storage_Error is raised. @node No_Standard_Storage_Pools,No_Stream_Optimizations,No_Standard_Allocators_After_Elaboration,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f2} @subsection No_Standard_Storage_Pools @@ -13059,7 +13078,7 @@ have an explicit Storage_Pool attribute defined specifying a user-defined storage pool. @node No_Stream_Optimizations,No_Streams,No_Standard_Storage_Pools,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f3} @subsection No_Stream_Optimizations @@ -13072,7 +13091,7 @@ due to their superior performance. When this restriction is in effect, the compiler performs all IO operations on a per-character basis. @node No_Streams,No_Task_Allocators,No_Stream_Optimizations,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f4} @subsection No_Streams @@ -13093,7 +13112,7 @@ unit declaring a tagged type should be compiled with the restriction, though this is not required. @node No_Task_Allocators,No_Task_At_Interrupt_Priority,No_Streams,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f5} @subsection No_Task_Allocators @@ -13103,7 +13122,7 @@ though this is not required. or types containing task subcomponents. @node No_Task_At_Interrupt_Priority,No_Task_Attributes_Package,No_Task_Allocators,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f6} @subsection No_Task_At_Interrupt_Priority @@ -13115,7 +13134,7 @@ a consequence, the tasks are always created with a priority below that an interrupt priority. @node No_Task_Attributes_Package,No_Task_Hierarchy,No_Task_At_Interrupt_Priority,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f7} @subsection No_Task_Attributes_Package @@ -13132,7 +13151,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node No_Task_Hierarchy,No_Task_Termination,No_Task_Attributes_Package,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f8} @subsection No_Task_Hierarchy @@ -13142,7 +13161,7 @@ warnings on obsolescent features are activated). directly on the environment task of the partition. @node No_Task_Termination,No_Tasking,No_Task_Hierarchy,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1f8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1f9} @subsection No_Task_Termination @@ -13151,7 +13170,7 @@ directly on the environment task of the partition. [RM D.7] Tasks that terminate are erroneous. @node No_Tasking,No_Terminate_Alternatives,No_Task_Termination,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1f9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1fa} @subsection No_Tasking @@ -13164,7 +13183,7 @@ and cause an error message to be output either by the compiler or binder. @node No_Terminate_Alternatives,No_Unchecked_Access,No_Tasking,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fa} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fb} @subsection No_Terminate_Alternatives @@ -13173,7 +13192,7 @@ binder. [RM D.7] There are no selective accepts with terminate alternatives. @node No_Unchecked_Access,No_Unchecked_Conversion,No_Terminate_Alternatives,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fc} @subsection No_Unchecked_Access @@ -13183,7 +13202,7 @@ binder. occurrences of the Unchecked_Access attribute. @node No_Unchecked_Conversion,No_Unchecked_Deallocation,No_Unchecked_Access,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fd} @subsection No_Unchecked_Conversion @@ -13193,7 +13212,7 @@ occurrences of the Unchecked_Access attribute. dependences on the predefined generic function Unchecked_Conversion. @node No_Unchecked_Deallocation,No_Use_Of_Entity,No_Unchecked_Conversion,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1fd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1fe} @subsection No_Unchecked_Deallocation @@ -13203,7 +13222,7 @@ dependences on the predefined generic function Unchecked_Conversion. dependences on the predefined generic procedure Unchecked_Deallocation. @node No_Use_Of_Entity,Pure_Barriers,No_Unchecked_Deallocation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1fe} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1ff} @subsection No_Use_Of_Entity @@ -13223,7 +13242,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line @end example @node Pure_Barriers,Simple_Barriers,No_Use_Of_Entity,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{1ff} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{200} @subsection Pure_Barriers @@ -13274,7 +13293,7 @@ but still ensures absence of side effects, exceptions, and recursion during the evaluation of the barriers. @node Simple_Barriers,Static_Priorities,Pure_Barriers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{200} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{201} @subsection Simple_Barriers @@ -13293,7 +13312,7 @@ compatibility purposes (and a warning will be generated for its use if warnings on obsolescent features are activated). @node Static_Priorities,Static_Storage_Size,Simple_Barriers,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{201} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{202} @subsection Static_Priorities @@ -13304,7 +13323,7 @@ are static, and that there are no dependences on the package @code{Ada.Dynamic_Priorities}. @node Static_Storage_Size,,Static_Priorities,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{202} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{203} @subsection Static_Storage_Size @@ -13314,7 +13333,7 @@ are static, and that there are no dependences on the package in a Storage_Size pragma or attribute definition clause is static. @node Program Unit Level Restrictions,,Partition-Wide Restrictions,Standard and Implementation Defined Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{203}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{204} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{204}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{205} @section Program Unit Level Restrictions @@ -13326,6 +13345,7 @@ other compilation units in the partition. @menu * No_Elaboration_Code:: +* No_Dynamic_Accessibility_Checks:: * No_Dynamic_Sized_Objects:: * No_Entry_Queue:: * No_Implementation_Aspect_Specifications:: @@ -13343,8 +13363,8 @@ other compilation units in the partition. @end menu -@node No_Elaboration_Code,No_Dynamic_Sized_Objects,,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{205} +@node No_Elaboration_Code,No_Dynamic_Accessibility_Checks,,Program Unit Level Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{206} @subsection No_Elaboration_Code @@ -13399,8 +13419,57 @@ used, the compiler is allowed to suppress the elaboration counter normally associated with the unit. This counter is typically used to check for access before elaboration and to control multiple elaboration attempts. -@node No_Dynamic_Sized_Objects,No_Entry_Queue,No_Elaboration_Code,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{206} +@node No_Dynamic_Accessibility_Checks,No_Dynamic_Sized_Objects,No_Elaboration_Code,Program Unit Level Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{207} +@subsection No_Dynamic_Accessibility_Checks + + +@geindex No_Dynamic_Accessibility_Checks + +[GNAT] No dynamic accessibility checks are generated when this restriction is +in effect. Instead, dangling references are prevented via more conservative +compile-time checking. More specifically, existing compile-time checks are +enforced but with more conservative assumptions about the accessibility levels +of the relevant entities. These conservative assumptions eliminate the need for +dynamic accessibility checks. + +These new rules for computing (at compile-time) the accessibility level of an +anonymous access type T are as follows: + + +@itemize * + +@item +If T is a function result type then, from the caller’s perspective, its level +is that of the innermost master enclosing the function call. From the callee’s +perspective, the level of parameters and local variables of the callee is +statically deeper than the level of T. + +For any other accessibility level L such that the level of parameters and local +variables of the callee is statically deeper than L, the level of T (from the +callee’s perspective) is also statically deeper than L. + +@item +If T is the type of a formal parameter then, from the caller’s perspective, +its level is at least as deep as that of the type of the corresponding actual +parameter (whatever that actual parameter might be). From the callee’s +perspective, the level of parameters and local variables of the callee is +statically deeper than the level of T. + +@item +If T is the type of a discriminant then its level is that of the discriminated +type. + +@item +If T is the type of a stand-alone object then its level is the level of the +object. + +@item +In all other cases, the level of T is as defined by the existing rules of Ada. +@end itemize + +@node No_Dynamic_Sized_Objects,No_Entry_Queue,No_Dynamic_Accessibility_Checks,Program Unit Level Restrictions +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{208} @subsection No_Dynamic_Sized_Objects @@ -13418,7 +13487,7 @@ access discriminants. It is often a good idea to combine this restriction with No_Secondary_Stack. @node No_Entry_Queue,No_Implementation_Aspect_Specifications,No_Dynamic_Sized_Objects,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{207} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{209} @subsection No_Entry_Queue @@ -13431,7 +13500,7 @@ checked at compile time. A program execution is erroneous if an attempt is made to queue a second task on such an entry. @node No_Implementation_Aspect_Specifications,No_Implementation_Attributes,No_Entry_Queue,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{208} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{20a} @subsection No_Implementation_Aspect_Specifications @@ -13442,7 +13511,7 @@ GNAT-defined aspects are present. With this restriction, the only aspects that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Attributes,No_Implementation_Identifiers,No_Implementation_Aspect_Specifications,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{209} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{20b} @subsection No_Implementation_Attributes @@ -13454,7 +13523,7 @@ attributes that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Identifiers,No_Implementation_Pragmas,No_Implementation_Attributes,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20c} @subsection No_Implementation_Identifiers @@ -13465,7 +13534,7 @@ implementation-defined identifiers (marked with pragma Implementation_Defined) occur within language-defined packages. @node No_Implementation_Pragmas,No_Implementation_Restrictions,No_Implementation_Identifiers,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20d} @subsection No_Implementation_Pragmas @@ -13476,7 +13545,7 @@ GNAT-defined pragmas are present. With this restriction, the only pragmas that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Restrictions,No_Implementation_Units,No_Implementation_Pragmas,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20e} @subsection No_Implementation_Restrictions @@ -13488,7 +13557,7 @@ are present. With this restriction, the only other restriction identifiers that can be used are those defined in the Ada Reference Manual. @node No_Implementation_Units,No_Implicit_Aliasing,No_Implementation_Restrictions,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20f} @subsection No_Implementation_Units @@ -13499,7 +13568,7 @@ mention in the context clause of any implementation-defined descendants of packages Ada, Interfaces, or System. @node No_Implicit_Aliasing,No_Implicit_Loops,No_Implementation_Units,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{20e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{210} @subsection No_Implicit_Aliasing @@ -13514,7 +13583,7 @@ to be aliased, and in such cases, it can always be replaced by the standard attribute Unchecked_Access which is preferable. @node No_Implicit_Loops,No_Obsolescent_Features,No_Implicit_Aliasing,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{20f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{211} @subsection No_Implicit_Loops @@ -13531,7 +13600,7 @@ arrays larger than about 5000 scalar components. Note that if this restriction is set in the spec of a package, it will not apply to its body. @node No_Obsolescent_Features,No_Wide_Characters,No_Implicit_Loops,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{210} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{212} @subsection No_Obsolescent_Features @@ -13541,7 +13610,7 @@ is set in the spec of a package, it will not apply to its body. features are used, as defined in Annex J of the Ada Reference Manual. @node No_Wide_Characters,Static_Dispatch_Tables,No_Obsolescent_Features,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{211} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{213} @subsection No_Wide_Characters @@ -13555,7 +13624,7 @@ appear in the program (that is literals representing characters not in type @code{Character}). @node Static_Dispatch_Tables,SPARK_05,No_Wide_Characters,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{212} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{214} @subsection Static_Dispatch_Tables @@ -13565,7 +13634,7 @@ type @code{Character}). associated with dispatch tables can be placed in read-only memory. @node SPARK_05,,Static_Dispatch_Tables,Program Unit Level Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{213} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{215} @subsection SPARK_05 @@ -13588,7 +13657,7 @@ gnatprove -P project.gpr --mode=check_all @end example @node Implementation Advice,Implementation Defined Characteristics,Standard and Implementation Defined Restrictions,Top -@anchor{gnat_rm/implementation_advice doc}@anchor{214}@anchor{gnat_rm/implementation_advice id1}@anchor{215}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} +@anchor{gnat_rm/implementation_advice doc}@anchor{216}@anchor{gnat_rm/implementation_advice id1}@anchor{217}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} @chapter Implementation Advice @@ -13686,7 +13755,7 @@ case the text describes what GNAT does and why. @end menu @node RM 1 1 3 20 Error Detection,RM 1 1 3 31 Child Units,,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{216} +@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{218} @section RM 1.1.3(20): Error Detection @@ -13703,7 +13772,7 @@ or diagnosed at compile time. @geindex Child Units @node RM 1 1 3 31 Child Units,RM 1 1 5 12 Bounded Errors,RM 1 1 3 20 Error Detection,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{217} +@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{219} @section RM 1.1.3(31): Child Units @@ -13719,7 +13788,7 @@ Followed. @geindex Bounded errors @node RM 1 1 5 12 Bounded Errors,RM 2 8 16 Pragmas,RM 1 1 3 31 Child Units,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{218} +@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{21a} @section RM 1.1.5(12): Bounded Errors @@ -13736,7 +13805,7 @@ runtime. @geindex Pragmas @node RM 2 8 16 Pragmas,RM 2 8 17-19 Pragmas,RM 1 1 5 12 Bounded Errors,Implementation Advice -@anchor{gnat_rm/implementation_advice id2}@anchor{219}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21a} +@anchor{gnat_rm/implementation_advice id2}@anchor{21b}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21c} @section RM 2.8(16): Pragmas @@ -13849,7 +13918,7 @@ that this advice not be followed. For details see @ref{7,,Implementation Defined Pragmas}. @node RM 2 8 17-19 Pragmas,RM 3 5 2 5 Alternative Character Sets,RM 2 8 16 Pragmas,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21b} +@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21d} @section RM 2.8(17-19): Pragmas @@ -13870,14 +13939,14 @@ replacing @code{library_items}.” @end itemize @end quotation -See @ref{21a,,RM 2.8(16); Pragmas}. +See @ref{21c,,RM 2.8(16); Pragmas}. @geindex Character Sets @geindex Alternative Character Sets @node RM 3 5 2 5 Alternative Character Sets,RM 3 5 4 28 Integer Types,RM 2 8 17-19 Pragmas,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21c} +@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21e} @section RM 3.5.2(5): Alternative Character Sets @@ -13905,7 +13974,7 @@ there is no such restriction. @geindex Integer types @node RM 3 5 4 28 Integer Types,RM 3 5 4 29 Integer Types,RM 3 5 2 5 Alternative Character Sets,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21d} +@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21f} @section RM 3.5.4(28): Integer Types @@ -13924,7 +13993,7 @@ are supported for convenient interface to C, and so that all hardware types of the machine are easily available. @node RM 3 5 4 29 Integer Types,RM 3 5 5 8 Enumeration Values,RM 3 5 4 28 Integer Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{21e} +@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{220} @section RM 3.5.4(29): Integer Types @@ -13940,7 +14009,7 @@ Followed. @geindex Enumeration values @node RM 3 5 5 8 Enumeration Values,RM 3 5 7 17 Float Types,RM 3 5 4 29 Integer Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{21f} +@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{221} @section RM 3.5.5(8): Enumeration Values @@ -13960,7 +14029,7 @@ Followed. @geindex Float types @node RM 3 5 7 17 Float Types,RM 3 6 2 11 Multidimensional Arrays,RM 3 5 5 8 Enumeration Values,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{220} +@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{222} @section RM 3.5.7(17): Float Types @@ -13990,7 +14059,7 @@ is a software rather than a hardware format. @geindex multidimensional @node RM 3 6 2 11 Multidimensional Arrays,RM 9 6 30-31 Duration’Small,RM 3 5 7 17 Float Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{221} +@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{223} @section RM 3.6.2(11): Multidimensional Arrays @@ -14008,7 +14077,7 @@ Followed. @geindex Duration'Small @node RM 9 6 30-31 Duration’Small,RM 10 2 1 12 Consistent Representation,RM 3 6 2 11 Multidimensional Arrays,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{222} +@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{224} @section RM 9.6(30-31): Duration’Small @@ -14029,7 +14098,7 @@ it need not be the same time base as used for @code{Calendar.Clock}.” Followed. @node RM 10 2 1 12 Consistent Representation,RM 11 4 1 19 Exception Information,RM 9 6 30-31 Duration’Small,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{223} +@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{225} @section RM 10.2.1(12): Consistent Representation @@ -14051,7 +14120,7 @@ advice without severely impacting efficiency of execution. @geindex Exception information @node RM 11 4 1 19 Exception Information,RM 11 5 28 Suppression of Checks,RM 10 2 1 12 Consistent Representation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{224} +@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{226} @section RM 11.4.1(19): Exception Information @@ -14082,7 +14151,7 @@ Pragma @code{Discard_Names}. @geindex suppression of @node RM 11 5 28 Suppression of Checks,RM 13 1 21-24 Representation Clauses,RM 11 4 1 19 Exception Information,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{225} +@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{227} @section RM 11.5(28): Suppression of Checks @@ -14097,7 +14166,7 @@ Followed. @geindex Representation clauses @node RM 13 1 21-24 Representation Clauses,RM 13 2 6-8 Packed Types,RM 11 5 28 Suppression of Checks,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{226} +@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{228} @section RM 13.1 (21-24): Representation Clauses @@ -14146,7 +14215,7 @@ Followed. @geindex Packed types @node RM 13 2 6-8 Packed Types,RM 13 3 14-19 Address Clauses,RM 13 1 21-24 Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{227} +@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{229} @section RM 13.2(6-8): Packed Types @@ -14185,7 +14254,7 @@ Followed. @geindex Address clauses @node RM 13 3 14-19 Address Clauses,RM 13 3 29-35 Alignment Clauses,RM 13 2 6-8 Packed Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{228} +@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{22a} @section RM 13.3(14-19): Address Clauses @@ -14238,7 +14307,7 @@ Followed. @geindex Alignment clauses @node RM 13 3 29-35 Alignment Clauses,RM 13 3 42-43 Size Clauses,RM 13 3 14-19 Address Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{229} +@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{22b} @section RM 13.3(29-35): Alignment Clauses @@ -14295,7 +14364,7 @@ Followed. @geindex Size clauses @node RM 13 3 42-43 Size Clauses,RM 13 3 50-56 Size Clauses,RM 13 3 29-35 Alignment Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{22a} +@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{22c} @section RM 13.3(42-43): Size Clauses @@ -14313,7 +14382,7 @@ object’s @code{Alignment} (if the @code{Alignment} is nonzero).” Followed. @node RM 13 3 50-56 Size Clauses,RM 13 3 71-73 Component Size Clauses,RM 13 3 42-43 Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22b} +@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22d} @section RM 13.3(50-56): Size Clauses @@ -14364,7 +14433,7 @@ Followed. @geindex Component_Size clauses @node RM 13 3 71-73 Component Size Clauses,RM 13 4 9-10 Enumeration Representation Clauses,RM 13 3 50-56 Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22c} +@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22e} @section RM 13.3(71-73): Component Size Clauses @@ -14398,7 +14467,7 @@ Followed. @geindex enumeration @node RM 13 4 9-10 Enumeration Representation Clauses,RM 13 5 1 17-22 Record Representation Clauses,RM 13 3 71-73 Component Size Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22d} +@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22f} @section RM 13.4(9-10): Enumeration Representation Clauses @@ -14420,7 +14489,7 @@ Followed. @geindex records @node RM 13 5 1 17-22 Record Representation Clauses,RM 13 5 2 5 Storage Place Attributes,RM 13 4 9-10 Enumeration Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{22e} +@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{230} @section RM 13.5.1(17-22): Record Representation Clauses @@ -14480,7 +14549,7 @@ and all mentioned features are implemented. @geindex Storage place attributes @node RM 13 5 2 5 Storage Place Attributes,RM 13 5 3 7-8 Bit Ordering,RM 13 5 1 17-22 Record Representation Clauses,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{22f} +@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{231} @section RM 13.5.2(5): Storage Place Attributes @@ -14500,7 +14569,7 @@ Followed. There are no such components in GNAT. @geindex Bit ordering @node RM 13 5 3 7-8 Bit Ordering,RM 13 7 37 Address as Private,RM 13 5 2 5 Storage Place Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{230} +@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{232} @section RM 13.5.3(7-8): Bit Ordering @@ -14520,7 +14589,7 @@ Thus non-default bit ordering is not supported. @geindex as private type @node RM 13 7 37 Address as Private,RM 13 7 1 16 Address Operations,RM 13 5 3 7-8 Bit Ordering,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{231} +@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{233} @section RM 13.7(37): Address as Private @@ -14538,7 +14607,7 @@ Followed. @geindex operations of @node RM 13 7 1 16 Address Operations,RM 13 9 14-17 Unchecked Conversion,RM 13 7 37 Address as Private,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{232} +@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{234} @section RM 13.7.1(16): Address Operations @@ -14556,7 +14625,7 @@ operation raises @code{Program_Error}, since all operations make sense. @geindex Unchecked conversion @node RM 13 9 14-17 Unchecked Conversion,RM 13 11 23-25 Implicit Heap Usage,RM 13 7 1 16 Address Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{233} +@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{235} @section RM 13.9(14-17): Unchecked Conversion @@ -14600,7 +14669,7 @@ Followed. @geindex implicit @node RM 13 11 23-25 Implicit Heap Usage,RM 13 11 2 17 Unchecked Deallocation,RM 13 9 14-17 Unchecked Conversion,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{234} +@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{236} @section RM 13.11(23-25): Implicit Heap Usage @@ -14651,7 +14720,7 @@ Followed. @geindex Unchecked deallocation @node RM 13 11 2 17 Unchecked Deallocation,RM 13 13 2 1 6 Stream Oriented Attributes,RM 13 11 23-25 Implicit Heap Usage,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{235} +@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{237} @section RM 13.11.2(17): Unchecked Deallocation @@ -14666,7 +14735,7 @@ Followed. @geindex Stream oriented attributes @node RM 13 13 2 1 6 Stream Oriented Attributes,RM A 1 52 Names of Predefined Numeric Types,RM 13 11 2 17 Unchecked Deallocation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{236} +@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{238} @section RM 13.13.2(1.6): Stream Oriented Attributes @@ -14697,7 +14766,7 @@ scalar types. This XDR alternative can be enabled via the binder switch -xdr. @geindex Stream oriented attributes @node RM A 1 52 Names of Predefined Numeric Types,RM A 3 2 49 Ada Characters Handling,RM 13 13 2 1 6 Stream Oriented Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{237} +@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{239} @section RM A.1(52): Names of Predefined Numeric Types @@ -14715,7 +14784,7 @@ Followed. @geindex Ada.Characters.Handling @node RM A 3 2 49 Ada Characters Handling,RM A 4 4 106 Bounded-Length String Handling,RM A 1 52 Names of Predefined Numeric Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{238} +@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{23a} @section RM A.3.2(49): @code{Ada.Characters.Handling} @@ -14732,7 +14801,7 @@ Followed. GNAT provides no such localized definitions. @geindex Bounded-length strings @node RM A 4 4 106 Bounded-Length String Handling,RM A 5 2 46-47 Random Number Generation,RM A 3 2 49 Ada Characters Handling,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{239} +@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{23b} @section RM A.4.4(106): Bounded-Length String Handling @@ -14747,7 +14816,7 @@ Followed. No implicit pointers or dynamic allocation are used. @geindex Random number generation @node RM A 5 2 46-47 Random Number Generation,RM A 10 7 23 Get_Immediate,RM A 4 4 106 Bounded-Length String Handling,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{23a} +@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{23c} @section RM A.5.2(46-47): Random Number Generation @@ -14776,7 +14845,7 @@ condition here to hold true. @geindex Get_Immediate @node RM A 10 7 23 Get_Immediate,RM A 18 Containers,RM A 5 2 46-47 Random Number Generation,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23b} +@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23d} @section RM A.10.7(23): @code{Get_Immediate} @@ -14800,7 +14869,7 @@ this functionality. @geindex Containers @node RM A 18 Containers,RM B 1 39-41 Pragma Export,RM A 10 7 23 Get_Immediate,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{23c} +@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{23e} @section RM A.18: @code{Containers} @@ -14821,7 +14890,7 @@ follow the implementation advice. @geindex Export @node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 18 Containers,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23d} +@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23f} @section RM B.1(39-41): Pragma @code{Export} @@ -14869,7 +14938,7 @@ Followed. @geindex Interfaces @node RM B 2 12-13 Package Interfaces,RM B 3 63-71 Interfacing with C,RM B 1 39-41 Pragma Export,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{23e} +@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{240} @section RM B.2(12-13): Package @code{Interfaces} @@ -14899,7 +14968,7 @@ Followed. GNAT provides all the packages described in this section. @geindex interfacing with @node RM B 3 63-71 Interfacing with C,RM B 4 95-98 Interfacing with COBOL,RM B 2 12-13 Package Interfaces,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{23f} +@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{241} @section RM B.3(63-71): Interfacing with C @@ -14987,7 +15056,7 @@ Followed. @geindex interfacing with @node RM B 4 95-98 Interfacing with COBOL,RM B 5 22-26 Interfacing with Fortran,RM B 3 63-71 Interfacing with C,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{240} +@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{242} @section RM B.4(95-98): Interfacing with COBOL @@ -15028,7 +15097,7 @@ Followed. @geindex interfacing with @node RM B 5 22-26 Interfacing with Fortran,RM C 1 3-5 Access to Machine Operations,RM B 4 95-98 Interfacing with COBOL,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{241} +@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{243} @section RM B.5(22-26): Interfacing with Fortran @@ -15079,7 +15148,7 @@ Followed. @geindex Machine operations @node RM C 1 3-5 Access to Machine Operations,RM C 1 10-16 Access to Machine Operations,RM B 5 22-26 Interfacing with Fortran,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{242} +@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{244} @section RM C.1(3-5): Access to Machine Operations @@ -15114,7 +15183,7 @@ object that is specified as exported.” Followed. @node RM C 1 10-16 Access to Machine Operations,RM C 3 28 Interrupt Support,RM C 1 3-5 Access to Machine Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{243} +@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{245} @section RM C.1(10-16): Access to Machine Operations @@ -15175,7 +15244,7 @@ Followed on any target supporting such operations. @geindex Interrupt support @node RM C 3 28 Interrupt Support,RM C 3 1 20-21 Protected Procedure Handlers,RM C 1 10-16 Access to Machine Operations,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{244} +@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{246} @section RM C.3(28): Interrupt Support @@ -15193,7 +15262,7 @@ of interrupt blocking. @geindex Protected procedure handlers @node RM C 3 1 20-21 Protected Procedure Handlers,RM C 3 2 25 Package Interrupts,RM C 3 28 Interrupt Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{245} +@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{247} @section RM C.3.1(20-21): Protected Procedure Handlers @@ -15219,7 +15288,7 @@ Followed. Compile time warnings are given when possible. @geindex Interrupts @node RM C 3 2 25 Package Interrupts,RM C 4 14 Pre-elaboration Requirements,RM C 3 1 20-21 Protected Procedure Handlers,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{246} +@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{248} @section RM C.3.2(25): Package @code{Interrupts} @@ -15237,7 +15306,7 @@ Followed. @geindex Pre-elaboration requirements @node RM C 4 14 Pre-elaboration Requirements,RM C 5 8 Pragma Discard_Names,RM C 3 2 25 Package Interrupts,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{247} +@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{249} @section RM C.4(14): Pre-elaboration Requirements @@ -15253,7 +15322,7 @@ Followed. Executable code is generated in some cases, e.g., loops to initialize large arrays. @node RM C 5 8 Pragma Discard_Names,RM C 7 2 30 The Package Task_Attributes,RM C 4 14 Pre-elaboration Requirements,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{248} +@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{24a} @section RM C.5(8): Pragma @code{Discard_Names} @@ -15271,7 +15340,7 @@ Followed. @geindex Task_Attributes @node RM C 7 2 30 The Package Task_Attributes,RM D 3 17 Locking Policies,RM C 5 8 Pragma Discard_Names,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{249} +@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{24b} @section RM C.7.2(30): The Package Task_Attributes @@ -15292,7 +15361,7 @@ Not followed. This implementation is not targeted to such a domain. @geindex Locking Policies @node RM D 3 17 Locking Policies,RM D 4 16 Entry Queuing Policies,RM C 7 2 30 The Package Task_Attributes,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{24a} +@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{24c} @section RM D.3(17): Locking Policies @@ -15309,7 +15378,7 @@ whose names (@code{Inheritance_Locking} and @geindex Entry queuing policies @node RM D 4 16 Entry Queuing Policies,RM D 6 9-10 Preemptive Abort,RM D 3 17 Locking Policies,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{24b} +@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{24d} @section RM D.4(16): Entry Queuing Policies @@ -15324,7 +15393,7 @@ Followed. No such implementation-defined queuing policies exist. @geindex Preemptive abort @node RM D 6 9-10 Preemptive Abort,RM D 7 21 Tasking Restrictions,RM D 4 16 Entry Queuing Policies,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24c} +@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24e} @section RM D.6(9-10): Preemptive Abort @@ -15350,7 +15419,7 @@ Followed. @geindex Tasking restrictions @node RM D 7 21 Tasking Restrictions,RM D 8 47-49 Monotonic Time,RM D 6 9-10 Preemptive Abort,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24d} +@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24f} @section RM D.7(21): Tasking Restrictions @@ -15369,7 +15438,7 @@ pragma @code{Profile (Restricted)} for more details. @geindex monotonic @node RM D 8 47-49 Monotonic Time,RM E 5 28-29 Partition Communication Subsystem,RM D 7 21 Tasking Restrictions,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{24e} +@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{250} @section RM D.8(47-49): Monotonic Time @@ -15404,7 +15473,7 @@ Followed. @geindex PCS @node RM E 5 28-29 Partition Communication Subsystem,RM F 7 COBOL Support,RM D 8 47-49 Monotonic Time,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{24f} +@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{251} @section RM E.5(28-29): Partition Communication Subsystem @@ -15432,7 +15501,7 @@ GNAT. @geindex COBOL support @node RM F 7 COBOL Support,RM F 1 2 Decimal Radix Support,RM E 5 28-29 Partition Communication Subsystem,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{250} +@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{252} @section RM F(7): COBOL Support @@ -15452,7 +15521,7 @@ Followed. @geindex Decimal radix support @node RM F 1 2 Decimal Radix Support,RM G Numerics,RM F 7 COBOL Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{251} +@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{253} @section RM F.1(2): Decimal Radix Support @@ -15468,7 +15537,7 @@ representations. @geindex Numerics @node RM G Numerics,RM G 1 1 56-58 Complex Types,RM F 1 2 Decimal Radix Support,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{252} +@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{254} @section RM G: Numerics @@ -15488,7 +15557,7 @@ Followed. @geindex Complex types @node RM G 1 1 56-58 Complex Types,RM G 1 2 49 Complex Elementary Functions,RM G Numerics,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{253} +@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{255} @section RM G.1.1(56-58): Complex Types @@ -15550,7 +15619,7 @@ Followed. @geindex Complex elementary functions @node RM G 1 2 49 Complex Elementary Functions,RM G 2 4 19 Accuracy Requirements,RM G 1 1 56-58 Complex Types,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{254} +@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{256} @section RM G.1.2(49): Complex Elementary Functions @@ -15572,7 +15641,7 @@ Followed. @geindex Accuracy requirements @node RM G 2 4 19 Accuracy Requirements,RM G 2 6 15 Complex Arithmetic Accuracy,RM G 1 2 49 Complex Elementary Functions,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{255} +@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{257} @section RM G.2.4(19): Accuracy Requirements @@ -15596,7 +15665,7 @@ Followed. @geindex complex arithmetic @node RM G 2 6 15 Complex Arithmetic Accuracy,RM H 6 15/2 Pragma Partition_Elaboration_Policy,RM G 2 4 19 Accuracy Requirements,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{256} +@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{258} @section RM G.2.6(15): Complex Arithmetic Accuracy @@ -15614,7 +15683,7 @@ Followed. @geindex Sequential elaboration policy @node RM H 6 15/2 Pragma Partition_Elaboration_Policy,,RM G 2 6 15 Complex Arithmetic Accuracy,Implementation Advice -@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{257} +@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{259} @section RM H.6(15/2): Pragma Partition_Elaboration_Policy @@ -15629,7 +15698,7 @@ immediately terminated.” Not followed. @node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top -@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{258}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{259}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b} +@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{25a}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{25b}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b} @chapter Implementation Defined Characteristics @@ -15705,7 +15774,13 @@ See separate section on source representation. @itemize * @item -“The control functions allowed in comments. See 2.1(14).” + +@table @asis + +@item “The semantics of an Ada program whose text is not in + +Normalization Form C. See 2.1(4).” +@end table @end itemize See separate section on source representation. @@ -15758,15 +15833,15 @@ not. @itemize * @item -“The sequence of characters of the value returned by -@code{S'Image} when some of the graphic characters of -@code{S'Wide_Image} are not defined in @code{Character}. See -3.5(37).” +“The message string associated with the Assertion_Error exception raised +by the failure of a predicate check if there is no applicable +Predicate_Failure aspect. See 3.2.4(31).” @end itemize -The sequence of characters is as defined by the wide character encoding -method used for the source. See section on source representation for -further details. +In the case of a Dynamic_Predicate aspect, the string is +“Dynamic_Predicate failed at <source position>”, where +“<source position>” might be something like “foo.adb:123”. +The Static_Predicate case is handled analogously. @itemize * @@ -15925,12 +16000,12 @@ IEEE 80-bit Extended on x86 architecture @end multitable -The default rounding mode specified by the IEEE 754 Standard is assumed for -static computations, i.e. round to nearest, ties to even. The input routines -yield correctly rounded values for Short_Float, Float and Long_Float at least. -The output routines can compute up to twice as many exact digits as the value -of @code{T'Digits} for any type, for example 30 digits for Long_Float; if more -digits are requested, zeros are printed. +The default rounding mode specified by the IEEE 754 Standard is assumed both +for static and dynamic computations (that is, round to nearest, ties to even). +The input routines yield correctly rounded values for Short_Float, Float, and +Long_Float at least. The output routines can compute up to twice as many exact +digits as the value of @code{T'Digits} for any type, for example 30 digits for +Long_Float; if more digits are requested, zeros are printed. @itemize * @@ -15986,6 +16061,19 @@ decimal integer are allocated. @itemize * @item +“The sequence of characters of the value returned by Tags.Expanded_Name +(respectively, Tags.Wide_Expanded_Name) when some of the graphic +characters of Tags.Wide_Wide_Expanded_Name are not defined in Character +(respectively, Wide_Character). See 3.9(10.1).” +@end itemize + +This is handled in the same way as the implementation-defined behavior +referenced in A.4.12(34). + + +@itemize * + +@item “Implementation-defined attributes. See 4.1.4(12).” @end itemize @@ -15995,6 +16083,90 @@ See @ref{8,,Implementation Defined Attributes}. @itemize * @item +“The value of the parameter to Empty for some container aggregates. +See 4.3.5(40).” +@end itemize + +As per the suggestion given in the Annotated Ada RM, the default value +of the formal parameter is used if one exists and zero is used otherwise. + + +@itemize * + +@item +“The maximum number of chunks for a parallel reduction expression without +a chunk_specification. See 4.5.10(21).” +@end itemize + +Feature unimplemented. + + +@itemize * + +@item +“Rounding of real static expressions which are exactly half-way between +two machine numbers. See 4.9(38).” +@end itemize + +Round to even is used in all such cases. + + +@itemize * + +@item + +@table @asis + +@item “The maximum number of chunks for a parallel generalized iterator without + +a chunk_specification. See 5.5.2(10).” +@end table +@end itemize + +Feature unimplemented. + + +@itemize * + +@item +“The number of chunks for an array component iterator. See 5.5.2(11).” +@end itemize + +Feature unimplemented. + + +@itemize * + +@item +“Any extensions of the Global aspect. See 6.1.2(43).” +@end itemize + +Feature unimplemented. + + +@itemize * + +@item +“The circumstances the implementation passes in the null value for a view +conversion of an access type used as an out parameter. See 6.4.1(19).” +@end itemize + +Difficult to characterize. + + +@itemize * + +@item +“Any extensions of the Default_Initial_Condition aspect. See 7.3.3(11).” +@end itemize + +SPARK allows specifying @emph{null} as the Default_Initial_Condition +aspect of a type. See the SPARK reference manual for further details. + + +@itemize * + +@item “Any implementation-defined time types. See 9.6(6).” @end itemize @@ -16004,7 +16176,7 @@ There are no implementation-defined time types. @itemize * @item -“The time base associated with relative delays.” +“The time base associated with relative delays. See 9.6(20).” @end itemize See 9.6(20). The time base used is that provided by the C library @@ -16014,8 +16186,7 @@ function @code{gettimeofday}. @itemize * @item -“The time base of the type @code{Calendar.Time}. See -9.6(23).” +“The time base of the type @code{Calendar.Time}. See 9.6(23).” @end itemize The time base used is that provided by the C library function @@ -16047,14 +16218,25 @@ There are no such limits. @itemize * @item -“Whether or not two non-overlapping parts of a composite -object are independently addressable, in the case where packing, record -layout, or @code{Component_Size} is specified for the object. See -9.10(1).” + +@table @asis + +@item “The result of Calendar.Formatting.Image if its argument represents more + +than 100 hours. See 9.6.1(86).” +@end table +@end itemize + +Calendar.Time_Error is raised. + + +@itemize * + +@item +“Implementation-defined conflict check policies. See 9.10.1(5).” @end itemize -Separate components are independently addressable if they do not share -overlapping storage units. +There are no implementation-defined conflict check policies. @itemize * @@ -16119,9 +16301,8 @@ options, refer to @emph{GNAT Make Program gnatmake} in the @itemize * @item -“The implementation-defined means, if any, of specifying -which compilation units are needed by a given compilation unit. See -10.2(2).” +“The implementation-defined means, if any, of specifying which compilation +units are needed by a given compilation unit. See 10.2(2).” @end itemize The units needed by a given compilation unit are as defined in @@ -16144,18 +16325,14 @@ corresponding @code{ALI} file as the input parameter to the binder. @itemize * @item -“The order of elaboration of @emph{library_items}. See -10.2(18).” +“The order of elaboration of @emph{library_items}. See 10.2(18).” @end itemize The first constraint on ordering is that it meets the requirements of Chapter 10 of the Ada Reference Manual. This still leaves some -implementation dependent choices, which are resolved by first -elaborating bodies as early as possible (i.e., in preference to specs -where there is a choice), and second by evaluating the immediate with -clauses of a unit to determine the probably best choice, and -third by elaborating in alphabetical order of unit names -where a choice still remains. +implementation-dependent choices, which are resolved by analyzing +the elaboration code of each unit and identifying implicit +elaboration-order dependencies. @itemize * @@ -16174,14 +16351,13 @@ may have been set by a call to @code{Ada.Command_Line.Set_Exit_Status}). @itemize * @item -“The mechanisms for building and running partitions. See -10.2(24).” +“The mechanisms for building and running partitions. See 10.2(24).” @end itemize -GNAT itself supports programs with only a single partition. The GNATDIST +GNAT itself supports programs with only a single partition. The GNATDIST tool provided with the GLADE package (which also includes an implementation of the PCS) provides a completely flexible method for building and running -programs consisting of multiple partitions. See the separate GLADE manual +programs consisting of multiple partitions. See the separate GLADE manual for details. @@ -16203,15 +16379,14 @@ implementation. See 10.2(28).” @end itemize Passive partitions are supported on targets where shared memory is -provided by the operating system. See the GLADE reference manual for +provided by the operating system. See the GLADE reference manual for further details. @itemize * @item -“The information returned by @code{Exception_Message}. See -11.4.1(10).” +“The information returned by @code{Exception_Message}. See 11.4.1(10).” @end itemize Exception message returns the null string unless a specific message has @@ -16282,6 +16457,54 @@ the last line is a single @code{LF} character (@code{16#0A#}). @itemize * @item +“The sequence of characters of the value returned by +Exceptions.Exception_Name (respectively, Exceptions.Wide_Exception_Name) +when some of the graphic characters of Exceptions.Wide_Wide_Exception_Name +are not defined in Character (respectively, Wide_Character). +See 11.4.1(12.1).” +@end itemize + +This is handled in the same way as the implementation-defined behavior +referenced in A.4.12(34). + + +@itemize * + +@item +“The information returned by Exception_Information. See 11.4.1(13).” +@end itemize + +The exception name and the source location at which the exception was +raised are included. + + +@itemize * + +@item +“Implementation-defined policy_identifiers and assertion_aspect_marks +allowed in a pragma Assertion_Policy. See 11.4.2(9).” +@end itemize + +Implementation-defined assertion_aspect_marks include Assert_And_Cut, +Assume, Contract_Cases, Debug, Ghost, Initial_Condition, Loop_Invariant, +Loop_Variant, Postcondition, Precondition, Predicate, Refined_Post, +Statement_Assertions, and Subprogram_Variant. Implementation-defined +policy_identifiers include Ignore and Suppressible. + + +@itemize * + +@item +“The default assertion policy. See 11.4.2(10).” +@end itemize + +The default assertion policy is Ignore, although this can be overridden +via compiler switches such as “-gnata”. + + +@itemize * + +@item “Implementation-defined check names. See 11.5(27).” @end itemize @@ -16295,8 +16518,33 @@ Check_Name. See the description of pragma @code{Suppress} for full details. @itemize * @item -“The interpretation of each aspect of representation. See -13.1(20).” +“Existence and meaning of second parameter of pragma Unsuppress. +See 11.5(27.1).” +@end itemize + +The legality rules for and semantics of the second parameter of pragma +Unsuppress match those for the second argument of pragma Suppress. + + +@itemize * + +@item + +@table @asis + +@item “The cases that cause conflicts between the representation of the + +ancestors of a type_declaration. See 13.1(13.1).” +@end table +@end itemize + +No such cases exist. + + +@itemize * + +@item +“The interpretation of each representation aspect. See 13.1(20).” @end itemize See separate section on data representations. @@ -16305,8 +16553,8 @@ See separate section on data representations. @itemize * @item -“Any restrictions placed upon representation items. See -13.1(20).” +“Any restrictions placed upon the specification of representation aspects. +See 13.1(20).” @end itemize See separate section on data representations. @@ -16315,20 +16563,46 @@ See separate section on data representations. @itemize * @item -“The meaning of @code{Size} for indefinite subtypes. See -13.3(48).” +“Implementation-defined aspects, including the syntax for specifying +such aspects and the legality rules for such aspects. See 13.1.1(38).” +@end itemize + +See @ref{121,,Implementation Defined Aspects}. + + +@itemize * + +@item +“The set of machine scalars. See 13.3(8.1).” @end itemize -Size for an indefinite subtype is the maximum possible size, except that -for the case of a subprogram parameter, the size of the parameter object -is the actual size. +See separate section on data representations. @itemize * @item -“The default external representation for a type tag. See -13.3(75).” +“The meaning of @code{Size} for indefinite subtypes. See 13.3(48).” +@end itemize + +The Size attribute of an indefinite subtype is not less than the Size +attribute of any object of that type. + + +@itemize * + +@item +“The meaning of Object_Size for indefinite subtypes. See 13.3(58).” +@end itemize + +The Object_Size attribute of an indefinite subtype is not less than the +Object_Size attribute of any object of that type. + + +@itemize * + +@item +“The default external representation for a type tag. See 13.3(75).” @end itemize The default external representation for a type tag is the fully expanded @@ -16371,13 +16645,11 @@ bit ordering corresponds to the natural endianness of the target architecture. @itemize * @item -“The contents of the visible part of package @code{System} -and its language-defined children. See 13.7(2).” +“The contents of the visible part of package @code{System}. See 13.7(2).” @end itemize -See the definition of these packages in files @code{system.ads} and -@code{s-stoele.ads}. Note that two declarations are added to package -System. +See the definition of package System in @code{system.ads}. +Note that two declarations are added to package System. @example Max_Priority : constant Positive := Priority'Last; @@ -16388,9 +16660,19 @@ Max_Interrupt_Priority : constant Positive := Interrupt_Priority'Last; @itemize * @item -“The contents of the visible part of package -@code{System.Machine_Code}, and the meaning of -@emph{code_statements}. See 13.8(7).” +“The range of Storage_Elements.Storage_Offset, the modulus of +Storage_Elements.Storage_Element, and the declaration of +Storage_Elements.Integer_Address. See 13.7.1(11).” +@end itemize + +See the definition of package System.Storage_Elements in @code{s-stoele.ads}. + + +@itemize * + +@item +“The contents of the visible part of package @code{System.Machine_Code}, +and the meaning of @emph{code_statements}. See 13.8(7).” @end itemize See the definition and documentation in file @code{s-maccod.ads}. @@ -16399,7 +16681,8 @@ See the definition and documentation in file @code{s-maccod.ads}. @itemize * @item -“The effect of unchecked conversion. See 13.9(11).” +“The result of unchecked conversion for instances with scalar result +types whose result is not defined by the language. See 13.9(11).” @end itemize Unchecked conversion between types of the same size @@ -16420,65 +16703,36 @@ made with appropriate alignment @itemize * @item -“The semantics of operations on invalid representations. -See 13.9.2(10-11).” +“The result of unchecked conversion for instances with nonscalar result +types whose result is not defined by the language. See 13.9(11).” @end itemize -For assignments and other operations where the use of invalid values cannot -result in erroneous behavior, the compiler ignores the possibility of invalid -values. An exception is raised at the point where an invalid value would -result in erroneous behavior. For example executing: - -@example -procedure invalidvals is - X : Integer := -1; - Y : Natural range 1 .. 10; - for Y'Address use X'Address; - Z : Natural range 1 .. 10; - A : array (Natural range 1 .. 10) of Integer; -begin - Z := Y; -- no exception - A (Z) := 3; -- exception raised; -end; -@end example - -As indicated, an exception is raised on the array assignment, but not -on the simple assignment of the invalid negative value from Y to Z. +See preceding definition for the scalar result case. @itemize * @item -“The manner of choosing a storage pool for an access type -when @code{Storage_Pool} is not specified for the type. See 13.11(17).” +“Whether or not the implementation provides user-accessible +names for the standard pool type(s). See 13.11(17).” @end itemize There are 3 different standard pools used by the compiler when @code{Storage_Pool} is not specified depending whether the type is local to a subprogram or defined at the library level and whether -@code{Storage_Size`@w{`}is specified or not. See documentation in the runtime +@code{Storage_Size`@w{`}is specified or not. See documentation in the runtime library units `@w{`}System.Pool_Global}, @code{System.Pool_Size} and @code{System.Pool_Local} in files @code{s-poosiz.ads}, @code{s-pooglo.ads} and @code{s-pooloc.ads} for full details on the -default pools used. - - -@itemize * - -@item -“Whether or not the implementation provides user-accessible -names for the standard pool type(s). See 13.11(17).” -@end itemize - -See documentation in the sources of the run time mentioned in the previous -paragraph. All these pools are accessible by means of @cite{with}ing +default pools used. All these pools are accessible by means of @cite{with}ing these units. @itemize * @item -“The meaning of @code{Storage_Size}. See 13.11(18).” +“The meaning of @code{Storage_Size} when neither the Storage_Size nor the +Storage_Pool is specified for an access type. See 13.11(18).” @end itemize @code{Storage_Size} is measured in storage units, and refers to the @@ -16489,20 +16743,19 @@ stack space for a task. @itemize * @item -“Implementation-defined aspects of storage pools. See -13.11(22).” +“The effect of specifying aspect Default_Storage_Pool on an instance +of a language-defined generic unit. See 13.11.3(5).” @end itemize -See documentation in the sources of the run time mentioned in the -paragraph about standard storage pools above -for details on GNAT-defined aspects of storage pools. +Instances of language-defined generic units are treated the same as other +instances with respect to the Default_Storage_Pool aspect. @itemize * @item -“The set of restrictions allowed in a pragma -@code{Restrictions}. See 13.12(7).” +“Implementation-defined restrictions allowed in a pragma +@code{Restrictions}. See 13.12(8.7).” @end itemize See @ref{9,,Standard and Implementation Defined Restrictions}. @@ -16515,17 +16768,26 @@ See @ref{9,,Standard and Implementation Defined Restrictions}. @code{Restrictions} pragmas. See 13.12(9).” @end itemize -Restrictions that can be checked at compile time result in illegalities -if violated. Currently there are no other consequences of violating -restrictions. +Restrictions that can be checked at compile time are enforced at +compile time; violations are illegal. For other restrictions, any +violation during program execution results in erroneous execution. + + +@itemize * + +@item +“Implementation-defined usage profiles allowed in a pragma Profile. +See 13.12(15).” +@end itemize + +See @ref{7,,Implementation Defined Pragmas}. @itemize * @item -“The representation used by the @code{Read} and -@code{Write} attributes of elementary types in terms of stream -elements. See 13.13.2(9).” +“The contents of the stream elements read and written by the Read and +Write attributes of elementary types. See 13.13.2(9).” @end itemize The representation is the in-memory representation of the base type of @@ -16546,13 +16808,38 @@ See items describing the integer and floating-point types supported. @itemize * @item -“The string returned by @code{Character_Set_Version}. -See A.3.5(3).” +“The values returned by Strings.Hash. See A.4.9(3).” +@end itemize + +This hash function has predictable collisions and is subject to +equivalent substring attacks. It is not suitable for construction of a +hash table keyed on possibly malicious user input. + + +@itemize * + +@item +“The value returned by a call to a Text_Buffer Get procedure if any +character in the returned sequence is not defined in Character. +See A.4.12(34).” +@end itemize + +The contents of a buffer is represented internally as a UTF_8 string. +The value return by Text_Buffer.Get is the result of passing that +UTF_8 string to UTF_Encoding.Strings.Decode. + + +@itemize * + +@item +“The value returned by a call to a Text_Buffer Wide_Get procedure if +any character in the returned sequence is not defined in Wide_Character. +See A.4.12(34).” @end itemize -@code{Ada.Wide_Characters.Handling.Character_Set_Version} returns -the string “Unicode 4.0”, referring to version 4.0 of the -Unicode specification. +The contents of a buffer is represented internally as a UTF_8 string. +The value return by Text_Buffer.Wide_Get is the result of passing that +UTF_8 string to UTF_Encoding.Wide_Strings.Decode. @itemize * @@ -16601,18 +16888,6 @@ Maximum image width is 6864, see library file @code{s-rannum.ads}. @itemize * @item -“The algorithms for random number generation. See -A.5.2(32).” -@end itemize - -The algorithm is the Mersenne Twister, as documented in the source file -@code{s-rannum.adb}. This version of the algorithm has a period of -2**19937-1. - - -@itemize * - -@item “The string representation of a random number generator’s state. See A.5.2(38).” @end itemize @@ -16625,44 +16900,20 @@ of the state vector. @itemize * @item -“The minimum time interval between calls to the -time-dependent Reset procedure that are guaranteed to initiate different -random number sequences. See A.5.2(45).” -@end itemize - -The minimum period between reset calls to guarantee distinct series of -random numbers is one microsecond. - - -@itemize * - -@item “The values of the @code{Model_Mantissa}, @code{Model_Emin}, @code{Model_Epsilon}, @code{Model}, @code{Safe_First}, and @code{Safe_Last} attributes, if the Numerics Annex is not supported. See A.5.3(72).” @end itemize -Run the compiler with @emph{-gnatS} to produce a listing of package -@code{Standard}, has the values of all numeric attributes. - - -@itemize * - -@item -“Any implementation-defined characteristics of the -input-output packages. See A.7(14).” -@end itemize - -There are no special implementation defined characteristics for these -packages. +Running the compiler with @emph{-gnatS} to produce a listing of package +@code{Standard} displays the values of these attributes. @itemize * @item -“The value of @code{Buffer_Size} in @code{Storage_IO}. See -A.9(10).” +“The value of @code{Buffer_Size} in @code{Storage_IO}. See A.9(10).” @end itemize All type representations are contiguous, and the @code{Buffer_Size} is @@ -16678,14 +16929,13 @@ standard error See A.10(5).” @end itemize These files are mapped onto the files provided by the C streams -libraries. See source file @code{i-cstrea.ads} for further details. +libraries. See source file @code{i-cstrea.ads} for further details. @itemize * @item -“The accuracy of the value produced by @code{Put}. See -A.10.9(36).” +“The accuracy of the value produced by @code{Put}. See A.10.9(36).” @end itemize If more digits are requested in the output than are represented by the @@ -16696,168 +16946,140 @@ significant digit positions. @itemize * @item -“The meaning of @code{Argument_Count}, @code{Argument}, and -@code{Command_Name}. See A.15(1).” +“Current size for a stream file for which positioning is not supported. +See A.12.1(1.1).” @end itemize -These are mapped onto the @code{argv} and @code{argc} parameters of the -main program in the natural manner. +Positioning is supported. @itemize * @item -“The interpretation of the @code{Form} parameter in procedure -@code{Create_Directory}. See A.16(56).” +“The meaning of @code{Argument_Count}, @code{Argument}, and +@code{Command_Name}. See A.15(1).” @end itemize -The @code{Form} parameter is not used. +These are mapped onto the @code{argv} and @code{argc} parameters of the +main program in the natural manner. @itemize * @item -“The interpretation of the @code{Form} parameter in procedure -@code{Create_Path}. See A.16(60).” +“The interpretation of file names and directory names. See A.16(46).” @end itemize -The @code{Form} parameter is not used. +These names are interpreted consistently with the underlying file system. @itemize * @item -“The interpretation of the @code{Form} parameter in procedure -@code{Copy_File}. See A.16(68).” +“The maxium value for a file size in Directories. See A.16(87).” @end itemize -The @code{Form} parameter is case-insensitive. -Two fields are recognized in the @code{Form} parameter: - -@example -*preserve=<value>* -*mode=<value>* -@end example - -<value> starts immediately after the character ‘=’ and ends with the -character immediately preceding the next comma (‘,’) or with the last -character of the parameter. - -The only possible values for preserve= are: - - -@multitable {xxxxxxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} -@headitem - -Value +Directories.File_Size’Last is equal to Long_Long_Integer’Last . -@tab - -Meaning -@item - -@emph{no_attributes} +@itemize * -@tab +@item -Do not try to preserve any file attributes. This is the -default if no preserve= is found in Form. +@table @asis -@item +@item “The result for Directories.Size for a directory or special file. -@emph{all_attributes} +See A.16(93).” +@end table +@end itemize -@tab +Name_Error is raised. -Try to preserve all file attributes (timestamps, access rights). -@item +@itemize * -@emph{timestamps} +@item -@tab +@table @asis -Preserve the timestamp of the copied file, but not the other -file attributes. +@item “The result for Directories.Modification_Time for a directory or special file. -@end multitable +See A.16(93).” +@end table +@end itemize +Name_Error is raised. -The only possible values for mode= are: +@itemize * -@multitable {xxxxxxxxxxxxxxxx} {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx} -@headitem +@item -Value +@table @asis -@tab +@item “The interpretation of a nonnull search pattern in Directories. -Meaning +See A.16(104).” +@end table +@end itemize -@item +When the @code{Pattern} parameter is not the null string, it is interpreted +according to the syntax of regular expressions as defined in the +@code{GNAT.Regexp} package. -@emph{copy} +See @ref{25c,,GNAT.Regexp (g-regexp.ads)}. -@tab -Only do the copy if the destination file does not already exist. -If it already exists, Copy_File fails. +@itemize * -@item +@item -@emph{overwrite} +@table @asis -@tab +@item “The results of a Directories search if the contents of the directory are -Copy the file in all cases. Overwrite an already existing destination file. +altered while a search is in progress. See A.16(110).” +@end table +@end itemize -@item +The effect of a call to Get_Next_Entry is determined by the current +state of the directory. -@emph{append} -@tab +@itemize * -Append the original file to the destination file. If the destination file -does not exist, the destination file is a copy of the source file. -When mode=append, the field preserve=, if it exists, is not taken into account. +@item +“The definition and meaning of an environment variable. See A.17(1).” +@end itemize -@end multitable +This definition is determined by the underlying operating system. -If the Form parameter includes one or both of the fields and the value or -values are incorrect, Copy_file fails with Use_Error. +@itemize * -Examples of correct Forms: +@item +“The circumstances where an environment variable cannot be defined. +See A.17(16).” -@example -Form => "preserve=no_attributes,mode=overwrite" (the default) -Form => "mode=append" -Form => "mode=copy, preserve=all_attributes" -@end example +There are no such implementation-defined circumstances. -Examples of incorrect Forms: +@item +“Environment names for which Set has the effect of Clear. See A.17(17).” +@end itemize -@example -Form => "preserve=junk" -Form => "mode=internal, preserve=timestamps" -@end example +There are no such names. @itemize * @item -“The interpretation of the @code{Pattern} parameter, when not the null string, -in the @code{Start_Search} and @code{Search} procedures. -See A.16(104) and A.16(112).” +“The value of Containers.Hash_Type’Modulus. The value of +Containers.Count_Type’Last. See A.18.1(7).” @end itemize -When the @code{Pattern} parameter is not the null string, it is interpreted -according to the syntax of regular expressions as defined in the -@code{GNAT.Regexp} package. - -See @ref{25a,,GNAT.Regexp (g-regexp.ads)}. +Containers.Hash_Type’Modulus is 2**32. +Containers.Count_Type’Last is 2**31 - 1. @itemize * @@ -17055,9 +17277,8 @@ Link names are the actual names used by the linker. @itemize * @item -“The manner of choosing link names when neither the link -name nor the address of an imported or exported entity is specified. See -B.1(36).” +“The manner of choosing link names when neither the link name nor the +address of an imported or exported entity is specified. See B.1(36).” @end itemize The default linker name is that which would be assigned by the relevant @@ -17110,6 +17331,16 @@ See files with prefix @code{i-} in the distributed library. @itemize * @item +“The definitions of certain types and constants in Interfaces.C. +See B.3(41).” +@end itemize + +See source file @code{i-c.ads}. + + +@itemize * + +@item “The types @code{Floating}, @code{Long_Floating}, @code{Binary}, @code{Long_Binary}, @code{Decimal_ Element}, and @code{COBOL_Character}; and the initialization of the variables @@ -17184,65 +17415,87 @@ For initialization, see the file @code{i-cobol.ads} in the distributed library. @itemize * @item -“Support for access to machine instructions. See C.1(1).” +“The types Fortran_Integer, Real, Double_Precision, and Character_Set +in Interfaces.Fortran. See B.5(17).” @end itemize -See documentation in file @code{s-maccod.ads} in the distributed library. +See source file @code{i-fortra.ads}. These types are derived, respectively, +from Integer, Float, Long_Float, and Character. @itemize * @item -“Implementation-defined aspects of access to machine -operations. See C.1(9).” +“Implementation-defined intrinsic subprograms. See C.1(1).” @end itemize -See documentation in file @code{s-maccod.ads} in the distributed library. +See separate section on Intrinsic Subprograms. @itemize * @item -“Implementation-defined aspects of interrupts. See C.3(2).” +“Any restrictions on a protected procedure or its containing type when an +aspect Attach_handler or Interrupt_Handler is specified. See C.3.1(17).” @end itemize -Interrupts are mapped to signals or conditions as appropriate. See -definition of unit -@code{Ada.Interrupt_Names} in source file @code{a-intnam.ads} for details -on the interrupts supported on a particular target. +There are no such restrictions. @itemize * @item -“Implementation-defined aspects of pre-elaboration. See -C.4(13).” +“Any other forms of interrupt handler supported by the Attach_Handler and +Interrupt_Handler aspects. See C.3.1(19).” @end itemize -GNAT does not permit a partition to be restarted without reloading, -except under control of the debugger. +There are no such forms. @itemize * @item -“The semantics of pragma @code{Discard_Names}. See C.5(7).” + +@table @asis + +@item “The semantics of some attributes and functions of an entity for which + +aspect Discard_Names is True. See C.5(7).” +@end table @end itemize -Pragma @code{Discard_Names} causes names of enumeration literals to -be suppressed. In the presence of this pragma, the Image attribute +If Discard_Names is True for an enumeration type, the Image attribute provides the image of the Pos of the literal, and Value accepts Pos values. -For tagged types, when pragmas @code{Discard_Names} and @code{No_Tagged_Streams} -simultaneously apply, their Expanded_Name and External_Tag are initialized -with empty strings. This is useful to avoid exposing entity names at binary +If both of the aspects`@w{`}Discard_Names`@w{`} and @code{No_Tagged_Streams} are true +for a tagged type, its Expanded_Name and External_Tag values are +empty strings. This is useful to avoid exposing entity names at binary level. @itemize * @item +“The modulus and size of Test_and_Set_Flag. See C.6.3(8).” +@end itemize + +The modulus is 2**8. The size is 8. + + +@itemize * + +@item +“The value used to represent the set value for Atomic_Test_and_Set. +See C.6.3(10).” +@end itemize + +The value is 1. + + +@itemize * + +@item “The result of the @code{Task_Identification.Image} attribute. See C.7.1(7).” @end itemize @@ -17286,41 +17539,12 @@ convenient thread, so the value of @code{Current_Task} is undefined. @itemize * @item -“The effect of calling @code{Current_Task} from an entry -body or interrupt handler. See C.7.1(19).” -@end itemize - -When GNAT can determine statically that @code{Current_Task} is called directly in -the body of an entry (or barrier) then a warning is emitted and @code{Program_Error} -is raised at run time. Otherwise, the effect of calling @code{Current_Task} from an -entry body or interrupt handler is to return the identification of the task -currently executing the code. - - -@itemize * - -@item -“Implementation-defined aspects of -@code{Task_Attributes}. See C.7.2(19).” -@end itemize - -There are no implementation-defined aspects of @code{Task_Attributes}. - - -@itemize * - -@item -“Values of all @code{Metrics}. See D(2).” +“Granularity of locking for Task_Attributes. See C.7.2(16).” @end itemize -The metrics information for GNAT depends on the performance of the -underlying operating system. The sources of the run-time for tasking -implementation, together with the output from @emph{-gnatG} can be -used to determine the exact sequence of operating systems calls made -to implement various tasking constructs. Together with appropriate -information on the performance of the underlying operating system, -on the exact target in use, this information can be used to determine -the required metrics. +No locking is needed if the formal type Attribute has the size and +alignment of either Integer or System.Address and the bit representation +of Initial_Value is all zeroes. Otherwise, locking is performed. @itemize * @@ -17368,32 +17592,19 @@ underlying operating system. @itemize * @item -“Implementation-defined @emph{policy_identifiers} allowed -in a pragma @code{Task_Dispatching_Policy}. See D.2.2(3).” -@end itemize - -There are no implementation-defined policy-identifiers allowed in this -pragma. - - -@itemize * - -@item -“Implementation-defined aspects of priority inversion. See -D.2.2(16).” +“Implementation-defined task dispatching policies. See D.2.2(3).” @end itemize -Execution of a task cannot be preempted by the implementation processing -of delay expirations for lower priority tasks. +There are no implementation-defined task dispatching policies. @itemize * @item -“Implementation-defined task dispatching. See D.2.2(18).” +“The value of Default_Quantum in Dispatching.Round_Robin. See D.2.5(4).” @end itemize -The policy is the same as that of the underlying threads implementation. +The value is 10 milliseconds. @itemize * @@ -17448,13 +17659,10 @@ There are no implementation-defined queuing policies. @itemize * @item -“On a multiprocessor, any conditions that cause the -completion of an aborted construct to be delayed later than what is -specified for a single processor. See D.6(3).” +“Implementation-defined admission policies. See D.4.1(1).” @end itemize -The semantics for abort on a multi-processor is the same as on a single -processor, there are no further delays. +There are no implementation-defined admission policies. @itemize * @@ -17471,8 +17679,39 @@ task creation. @itemize * @item -“What happens when a task terminates in the presence of -pragma @code{No_Task_Termination}. See D.7(15).” +“When restriction No_Dynamic_CPU_Assignment applies to a partition, the +processor on which a task with a CPU value of a Not_A_Specific_CPU will +execute. See D.7(10).” +@end itemize + +Unknown. + + +@itemize * + +@item + +@table @asis + +@item “When restriction No_Task_Termination applies to a partition, what happens + +when a task terminates. See D.7(15.1).” +@end table +@end itemize + +Execution is erroneous in that case. + + +@itemize * + +@item + +@table @asis + +@item “The behavior when restriction Max_Storage_At_Blocking is violated. + +See D.7(17).” +@end table @end itemize Execution is erroneous in that case. @@ -17481,43 +17720,85 @@ Execution is erroneous in that case. @itemize * @item -“Implementation-defined aspects of pragma -@code{Restrictions}. See D.7(20).” +“The behavior when restriction Max_Asynchronous_Select_Nesting is violated. +See D.7(18).” +@end itemize + +Execution is erroneous in that case. + + +@itemize * + +@item +“The behavior when restriction Max_Tasks is violated. See D.7(19).” +@end itemize + +Execution is erroneous in that case. + + +@itemize * + +@item + +@table @asis + +@item “Whether the use of pragma Restrictions results in a reduction in program + +code or data size or execution time. See D.7(20).” + +Yes it can, but the precise circumstances and properties of such reductions +are difficult to characterize. +@end table + +@item +“The value of Barrier_Limit’Last in Synchronous_Barriers. See D.10.1(4).” +@end itemize + +Synchronous_Barriers.Barrier_Limit’Last is Integer’Last . + + +@itemize * + +@item +“When an aborted task that is waiting on a Synchronous_Barrier is aborted. +See D.10.1(13).” @end itemize -There are no such implementation-defined aspects. +Difficult to characterize. @itemize * @item -“Implementation-defined aspects of package -@code{Real_Time}. See D.8(17).” + +@table @asis + +@item “The value of Min_Handler_Ceiling in Execution_Time.Group_Budgets. + +See D.14.2(7).” +@end table @end itemize -There are no implementation defined aspects of package @code{Real_Time}. +See source file @code{a-etgrbu.ads}. @itemize * @item -“Implementation-defined aspects of -@emph{delay_statements}. See D.9(8).” +“The value of CPU_Range’Last in System.Multiprocessors. See D.16(4).” @end itemize -Any difference greater than one microsecond will cause the task to be -delayed (see D.9(7)). +See source file @code{s-multip.ads}. @itemize * @item -“The upper bound on the duration of interrupt blocking -caused by the implementation. See D.12(5).” +“The processor on which the environment task executes in the absence +of a value for the aspect CPU. See D.16(13).” @end itemize -The upper bound is determined by the underlying operating system. In -no cases is it more than 10 milliseconds. +Unknown. @itemize * @@ -17528,7 +17809,7 @@ programs. See E(5).” @end itemize The GLADE package provides a utility GNATDIST for creating and executing -distributed programs. See the GLADE reference manual for further details. +distributed programs. See the GLADE reference manual for further details. @itemize * @@ -17544,9 +17825,8 @@ See the GLADE reference manual for full details on such events. @itemize * @item -“The scheduling policies, treatment of priorities, and -management of shared resources between partitions in certain cases. See -E.1(11).” +“The scheduling policies, treatment of priorities, and management of +shared resources between partitions in certain cases. See E.1(11).” @end itemize See the GLADE reference manual for full details on these aspects of @@ -17556,20 +17836,6 @@ multi-partition execution. @itemize * @item -“Events that cause the version of a compilation unit to -change. See E.3(5).” -@end itemize - -Editing the source file of a compilation unit, or the source files of -any units on which it is dependent in a significant way cause the version -to change. No other actions cause the version number to change. All changes -are significant except those which affect only layout, capitalization or -comments. - - -@itemize * - -@item “Whether the execution of the remote subprogram is immediately aborted as a result of cancellation. See E.4(13).” @end itemize @@ -17581,18 +17847,16 @@ a distributed application. @itemize * @item -“Implementation-defined aspects of the PCS. See E.5(25).” +“The range of type System.RPC.Partition_Id. See E.5(14).” @end itemize -See the GLADE reference manual for a full description of all implementation -defined aspects of the PCS. +System.RPC.Partion_ID’Last is Integer’Last. See source file @code{s-rpc.ads}. @itemize * @item -“Implementation-defined interfaces in the PCS. See -E.5(26).” +“Implementation-defined interfaces in the PCS. See E.5(26).” @end itemize See the GLADE reference manual for a full description of all @@ -17770,9 +18034,8 @@ Not relevant, division is IEEE exact. @itemize * @item -“The definition of close result set, which determines the -accuracy of certain fixed point multiplications and divisions. See -G.2.3(5).” +“The definition of close result set, which determines the accuracy of +certain fixed point multiplications and divisions. See G.2.3(5).” @end itemize Operations in the close result set are performed using IEEE long format @@ -17865,47 +18128,45 @@ Information on those subjects is not yet available. @itemize * @item -“Information regarding bounded errors and erroneous -execution. See H.2(1).” -@end itemize - -Information on this subject is not yet available. +@table @asis -@itemize * +@item “The accuracy requirements for the subprograms Solve, Inverse, -@item -“Implementation-defined aspects of pragma -@code{Inspection_Point}. See H.3.2(8).” +Determinant, Eigenvalues and Eigensystem for type Real_Matrix. +See G.3.1(81).” +@end table @end itemize -Pragma @code{Inspection_Point} ensures that the variable is live and can -be examined by the debugger at the inspection point. +Information on those subjects is not yet available. @itemize * @item -“Implementation-defined aspects of pragma -@code{Restrictions}. See H.4(25).” + +@table @asis + +@item “The accuracy requirements for the subprograms Solve, Inverse, + +Determinant, Eigenvalues and Eigensystem for type Complex_Matrix. +See G.3.2(149).” +@end table @end itemize -There are no implementation-defined aspects of pragma @code{Restrictions}. The -use of pragma @code{Restrictions [No_Exceptions]} has no effect on the -generated code. Checks must suppressed by use of pragma @code{Suppress}. +Information on those subjects is not yet available. @itemize * @item -“Any restrictions on pragma @code{Restrictions}. See -H.4(27).” +“The consequences of violating No_Hidden_Indirect_Globals. See H.4(23.9).” @end itemize -There are no restrictions on pragma @code{Restrictions}. +Execution is erroneous in that case. @node Intrinsic Subprograms,Representation Clauses and Pragmas,Implementation Defined Characteristics,Top -@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{25b}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25c}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} +@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25e}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} @chapter Intrinsic Subprograms @@ -17943,7 +18204,7 @@ Ada standard does not require Ada compilers to implement this feature. @end menu @node Intrinsic Operators,Compilation_ISO_Date,,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{25e} +@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{260} @section Intrinsic Operators @@ -17974,7 +18235,7 @@ It is also possible to specify such operators for private types, if the full views are appropriate arithmetic types. @node Compilation_ISO_Date,Compilation_Date,Intrinsic Operators,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{260} +@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{262} @section Compilation_ISO_Date @@ -17988,7 +18249,7 @@ application program should simply call the function the current compilation (in local time format YYYY-MM-DD). @node Compilation_Date,Compilation_Time,Compilation_ISO_Date,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{262} +@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{263}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{264} @section Compilation_Date @@ -17998,7 +18259,7 @@ Same as Compilation_ISO_Date, except the string is in the form MMM DD YYYY. @node Compilation_Time,Enclosing_Entity,Compilation_Date,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{263}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{264} +@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{265}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{266} @section Compilation_Time @@ -18012,7 +18273,7 @@ application program should simply call the function the current compilation (in local time format HH:MM:SS). @node Enclosing_Entity,Exception_Information,Compilation_Time,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{265}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{266} +@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{267}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{268} @section Enclosing_Entity @@ -18026,7 +18287,7 @@ application program should simply call the function the current subprogram, package, task, entry, or protected subprogram. @node Exception_Information,Exception_Message,Enclosing_Entity,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{267}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{268} +@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{269}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{26a} @section Exception_Information @@ -18040,7 +18301,7 @@ so an application program should simply call the function the exception information associated with the current exception. @node Exception_Message,Exception_Name,Exception_Information,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{269}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26a} +@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{26b}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26c} @section Exception_Message @@ -18054,7 +18315,7 @@ so an application program should simply call the function the message associated with the current exception. @node Exception_Name,File,Exception_Message,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{26b}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26c} +@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26e} @section Exception_Name @@ -18068,7 +18329,7 @@ so an application program should simply call the function the name of the current exception. @node File,Line,Exception_Name,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{26e} +@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26f}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{270} @section File @@ -18082,7 +18343,7 @@ application program should simply call the function file. @node Line,Shifts and Rotates,File,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{26f}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{270} +@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{272} @section Line @@ -18096,7 +18357,7 @@ application program should simply call the function source line. @node Shifts and Rotates,Source_Location,Line,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{272} +@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{273}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{274} @section Shifts and Rotates @@ -18139,7 +18400,7 @@ corresponding operator for modular type. In particular, shifting a negative number may change its sign bit to positive. @node Source_Location,,Shifts and Rotates,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{273}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{274} +@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{275}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{276} @section Source_Location @@ -18153,7 +18414,7 @@ application program should simply call the function source file location. @node Representation Clauses and Pragmas,Standard Library Routines,Intrinsic Subprograms,Top -@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{275}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{276}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} +@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{277}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{278}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} @chapter Representation Clauses and Pragmas @@ -18199,7 +18460,7 @@ and this section describes the additional capabilities provided. @end menu @node Alignment Clauses,Size Clauses,,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{277}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{278} +@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{27a} @section Alignment Clauses @@ -18221,7 +18482,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{18d,,Attribute Maximum_Alignment}.) +@code{Standard'Maximum_Alignment}; see @ref{18e,,Attribute Maximum_Alignment}.) @geindex Maximum_Alignment attribute @@ -18330,7 +18591,7 @@ assumption is non-portable, and other compilers may choose different alignments for the subtype @code{RS}. @node Size Clauses,Storage_Size Clauses,Alignment Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27a} +@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27c} @section Size Clauses @@ -18407,7 +18668,7 @@ if it is known that a Size value can be accommodated in an object of type Integer. @node Storage_Size Clauses,Size of Variant Record Objects,Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27c} +@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27e} @section Storage_Size Clauses @@ -18480,7 +18741,7 @@ Of course in practice, there will not be any explicit allocators in the case of such an access declaration. @node Size of Variant Record Objects,Biased Representation,Storage_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{27e} +@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{280} @section Size of Variant Record Objects @@ -18590,7 +18851,7 @@ the maximum size, regardless of the current variant value, the variant value. @node Biased Representation,Value_Size and Object_Size Clauses,Size of Variant Record Objects,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{280} +@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{282} @section Biased Representation @@ -18628,7 +18889,7 @@ biased representation can be used for all discrete types except for enumeration types for which a representation clause is given. @node Value_Size and Object_Size Clauses,Component_Size Clauses,Biased Representation,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{282} +@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{284} @section Value_Size and Object_Size Clauses @@ -18944,7 +19205,7 @@ definition clause forces biased representation. This warning can be turned off using @code{-gnatw.B}. @node Component_Size Clauses,Bit_Order Clauses,Value_Size and Object_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{284} +@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{286} @section Component_Size Clauses @@ -18992,7 +19253,7 @@ and a pragma Pack for the same array type. if such duplicate clauses are given, the pragma Pack will be ignored. @node Bit_Order Clauses,Effect of Bit_Order on Byte Ordering,Component_Size Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{286} +@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{287}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{288} @section Bit_Order Clauses @@ -19098,7 +19359,7 @@ if desired. The following section contains additional details regarding the issue of byte ordering. @node Effect of Bit_Order on Byte Ordering,Pragma Pack for Arrays,Bit_Order Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{287}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{288} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{28a} @section Effect of Bit_Order on Byte Ordering @@ -19355,7 +19616,7 @@ to set the boolean constant @code{Master_Byte_First} in an appropriate manner. @node Pragma Pack for Arrays,Pragma Pack for Records,Effect of Bit_Order on Byte Ordering,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28a} +@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28c} @section Pragma Pack for Arrays @@ -19475,7 +19736,7 @@ Here 31-bit packing is achieved as required, and no warning is generated, since in this case the programmer intention is clear. @node Pragma Pack for Records,Record Representation Clauses,Pragma Pack for Arrays,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28c} +@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28d}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28e} @section Pragma Pack for Records @@ -19559,7 +19820,7 @@ array that is longer than 64 bits, so it is itself non-packable on 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{28d}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{28e} +@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28f}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{290} @section Record Representation Clauses @@ -19638,7 +19899,7 @@ end record; @end example @node Handling of Records with Holes,Enumeration Clauses,Record Representation Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{28f}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{290} +@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{292} @section Handling of Records with Holes @@ -19714,7 +19975,7 @@ for Hrec'Size use 64; @end example @node Enumeration Clauses,Address Clauses,Handling of Records with Holes,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{292} +@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{294} @section Enumeration Clauses @@ -19757,7 +20018,7 @@ the overhead of converting representation values to the corresponding positional values, (i.e., the value delivered by the @code{Pos} attribute). @node Address Clauses,Use of Address Clauses for Memory-Mapped I/O,Enumeration Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{294} +@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{296} @section Address Clauses @@ -20086,7 +20347,7 @@ then the program compiles without the warning and when run will generate the output @code{X was not clobbered}. @node Use of Address Clauses for Memory-Mapped I/O,Effect of Convention on Representation,Address Clauses,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{296} +@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{298} @section Use of Address Clauses for Memory-Mapped I/O @@ -20144,7 +20405,7 @@ provides the pragma @code{Volatile_Full_Access} which can be used in lieu of pragma @code{Atomic} and will give the additional guarantee. @node Effect of Convention on Representation,Conventions and Anonymous Access Types,Use of Address Clauses for Memory-Mapped I/O,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{298} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{29a} @section Effect of Convention on Representation @@ -20222,7 +20483,7 @@ when one of these values is read, any nonzero value is treated as True. @end itemize @node Conventions and Anonymous Access Types,Determining the Representations chosen by GNAT,Effect of Convention on Representation,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29a} +@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29c} @section Conventions and Anonymous Access Types @@ -20298,7 +20559,7 @@ package ConvComp is @end example @node Determining the Representations chosen by GNAT,,Conventions and Anonymous Access Types,Representation Clauses and Pragmas -@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29c} +@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29d}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29e} @section Determining the Representations chosen by GNAT @@ -20450,7 +20711,7 @@ generated by the compiler into the original source to fix and guarantee the actual representation to be used. @node Standard Library Routines,The Implementation of Standard I/O,Representation Clauses and Pragmas,Top -@anchor{gnat_rm/standard_library_routines doc}@anchor{29d}@anchor{gnat_rm/standard_library_routines id1}@anchor{29e}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} +@anchor{gnat_rm/standard_library_routines doc}@anchor{29f}@anchor{gnat_rm/standard_library_routines id1}@anchor{2a0}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} @chapter Standard Library Routines @@ -21274,7 +21535,7 @@ For packages in Interfaces and System, all the RM defined packages are available in GNAT, see the Ada 2012 RM for full details. @node The Implementation of Standard I/O,The GNAT Library,Standard Library Routines,Top -@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{29f}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a0}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f} +@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{2a1}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a2}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f} @chapter The Implementation of Standard I/O @@ -21326,7 +21587,7 @@ these additional facilities are also described in this chapter. @end menu @node Standard I/O Packages,FORM Strings,,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a1}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a2} +@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a4} @section Standard I/O Packages @@ -21397,7 +21658,7 @@ flush the common I/O streams and in particular Standard_Output before elaborating the Ada code. @node FORM Strings,Direct_IO,Standard I/O Packages,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a4} +@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a6} @section FORM Strings @@ -21423,7 +21684,7 @@ unrecognized keyword appears in a form string, it is silently ignored and not considered invalid. @node Direct_IO,Sequential_IO,FORM Strings,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a6} +@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a8} @section Direct_IO @@ -21443,7 +21704,7 @@ There is no limit on the size of Direct_IO files, they are expanded as necessary to accommodate whatever records are written to the file. @node Sequential_IO,Text_IO,Direct_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2a8} +@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2aa} @section Sequential_IO @@ -21490,7 +21751,7 @@ using Stream_IO, and this is the preferred mechanism. In particular, the above program fragment rewritten to use Stream_IO will work correctly. @node Text_IO,Wide_Text_IO,Sequential_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2aa} +@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2ac} @section Text_IO @@ -21573,7 +21834,7 @@ the file. @end menu @node Stream Pointer Positioning,Reading and Writing Non-Regular Files,,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ac} +@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ae} @subsection Stream Pointer Positioning @@ -21609,7 +21870,7 @@ between two Ada files, then the difference may be observable in some situations. @node Reading and Writing Non-Regular Files,Get_Immediate,Stream Pointer Positioning,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2ae} +@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2b0} @subsection Reading and Writing Non-Regular Files @@ -21660,7 +21921,7 @@ to read data past that end of file indication, until another end of file indication is entered. @node Get_Immediate,Treating Text_IO Files as Streams,Reading and Writing Non-Regular Files,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b0} +@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b2} @subsection Get_Immediate @@ -21678,7 +21939,7 @@ possible), it is undefined whether the FF character will be treated as a page mark. @node Treating Text_IO Files as Streams,Text_IO Extensions,Get_Immediate,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b2} +@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b4} @subsection Treating Text_IO Files as Streams @@ -21694,7 +21955,7 @@ skipped and the effect is similar to that described above for @code{Get_Immediate}. @node Text_IO Extensions,Text_IO Facilities for Unbounded Strings,Treating Text_IO Files as Streams,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b4} +@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b6} @subsection Text_IO Extensions @@ -21722,7 +21983,7 @@ the string is to be read. @end itemize @node Text_IO Facilities for Unbounded Strings,,Text_IO Extensions,Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b6} +@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b8} @subsection Text_IO Facilities for Unbounded Strings @@ -21770,7 +22031,7 @@ files @code{a-szuzti.ads} and @code{a-szuzti.adb} provides similar extended @code{Wide_Wide_Text_IO} functionality for unbounded wide wide strings. @node Wide_Text_IO,Wide_Wide_Text_IO,Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2b8} +@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2ba} @section Wide_Text_IO @@ -22017,12 +22278,12 @@ input also causes Constraint_Error to be raised. @end menu @node Stream Pointer Positioning<2>,Reading and Writing Non-Regular Files<2>,,Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2ba} +@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2bc} @subsection Stream Pointer Positioning @code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{2aa,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2ac,,Text_IO}). There is one additional case: If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22041,7 +22302,7 @@ to a normal program using @code{Wide_Text_IO}. However, this discrepancy can be observed if the wide text file shares a stream with another file. @node Reading and Writing Non-Regular Files<2>,,Stream Pointer Positioning<2>,Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2bc} +@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2be} @subsection Reading and Writing Non-Regular Files @@ -22052,7 +22313,7 @@ treated as data characters), and @code{End_Of_Page} always returns it is possible to read beyond an end of file. @node Wide_Wide_Text_IO,Stream_IO,Wide_Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2be} +@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2c0} @section Wide_Wide_Text_IO @@ -22221,12 +22482,12 @@ input also causes Constraint_Error to be raised. @end menu @node Stream Pointer Positioning<3>,Reading and Writing Non-Regular Files<3>,,Wide_Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c0} +@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c2} @subsection Stream Pointer Positioning @code{Ada.Wide_Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{2aa,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2ac,,Text_IO}). There is one additional case: If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22245,7 +22506,7 @@ to a normal program using @code{Wide_Wide_Text_IO}. However, this discrepancy can be observed if the wide text file shares a stream with another file. @node Reading and Writing Non-Regular Files<3>,,Stream Pointer Positioning<3>,Wide_Wide_Text_IO -@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c2} +@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c4} @subsection Reading and Writing Non-Regular Files @@ -22256,7 +22517,7 @@ treated as data characters), and @code{End_Of_Page} always returns it is possible to read beyond an end of file. @node Stream_IO,Text Translation,Wide_Wide_Text_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c4} +@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c6} @section Stream_IO @@ -22278,7 +22539,7 @@ manner described for stream attributes. @end itemize @node Text Translation,Shared Files,Stream_IO,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c6} +@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c8} @section Text Translation @@ -22312,7 +22573,7 @@ mode. (corresponds to_O_U16TEXT). @end itemize @node Shared Files,Filenames encoding,Text Translation,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2c8} +@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2ca} @section Shared Files @@ -22375,7 +22636,7 @@ heterogeneous input-output. Although this approach will work in GNAT if for this purpose (using the stream attributes) @node Filenames encoding,File content encoding,Shared Files,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2ca} +@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2cc} @section Filenames encoding @@ -22415,7 +22676,7 @@ platform. On the other Operating Systems the run-time is supporting UTF-8 natively. @node File content encoding,Open Modes,Filenames encoding,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2cc} +@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ce} @section File content encoding @@ -22448,7 +22709,7 @@ Unicode 8-bit encoding This encoding is only supported on the Windows platform. @node Open Modes,Operations on C Streams,File content encoding,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2ce} +@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2d0} @section Open Modes @@ -22551,7 +22812,7 @@ subsequently requires switching from reading to writing or vice-versa, then the file is reopened in @code{r+} mode to permit the required operation. @node Operations on C Streams,Interfacing to C Streams,Open Modes,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d0} +@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d2} @section Operations on C Streams @@ -22711,7 +22972,7 @@ end Interfaces.C_Streams; @end example @node Interfacing to C Streams,,Operations on C Streams,The Implementation of Standard I/O -@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d2} +@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d3}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d4} @section Interfacing to C Streams @@ -22804,7 +23065,7 @@ imported from a C program, allowing an Ada file to operate on an existing C file. @node The GNAT Library,Interfacing to Other Languages,The Implementation of Standard I/O,Top -@anchor{gnat_rm/the_gnat_library doc}@anchor{2d3}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d4}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} +@anchor{gnat_rm/the_gnat_library doc}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d6}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} @chapter The GNAT Library @@ -22998,7 +23259,7 @@ of GNAT, and will generate a warning message. @end menu @node Ada Characters Latin_9 a-chlat9 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d6} +@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d7}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d8} @section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads}) @@ -23015,7 +23276,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_1 a-cwila1 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Latin_9 a-chlat9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d7}@anchor{gnat_rm/the_gnat_library id3}@anchor{2d8} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id3}@anchor{2da} @section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads}) @@ -23032,7 +23293,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id4}@anchor{2da} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id4}@anchor{2dc} @section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads}) @@ -23049,7 +23310,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id5}@anchor{2dc} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id5}@anchor{2de} @section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads}) @@ -23066,7 +23327,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id6}@anchor{2de} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2df}@anchor{gnat_rm/the_gnat_library id6}@anchor{2e0} @section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads}) @@ -23083,7 +23344,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2df}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e0} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2e1}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e2} @section @code{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads}) @@ -23102,7 +23363,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e1}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e2} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e3}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e4} @section @code{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads}) @@ -23121,7 +23382,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e3}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e4} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e6} @section @code{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads}) @@ -23140,7 +23401,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e6} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e8} @section @code{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads}) @@ -23159,7 +23420,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Ordered_Maps a-cforma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id11}@anchor{2e8} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2e9}@anchor{gnat_rm/the_gnat_library id11}@anchor{2ea} @section @code{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads}) @@ -23178,7 +23439,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Formal_Ordered_Sets a-cforse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2e9}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ea} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ec} @section @code{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads}) @@ -23197,7 +23458,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Formal_Vectors a-cofove ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ec} +@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2ed}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ee} @section @code{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads}) @@ -23216,7 +23477,7 @@ efficient version than the one defined in the standard. In particular it does not have the complex overhead required to detect cursor tampering. @node Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Functional_Sets a-cofuse ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ed}@anchor{gnat_rm/the_gnat_library id14}@anchor{2ee} +@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id14}@anchor{2f0} @section @code{Ada.Containers.Functional_Vectors} (@code{a-cofuve.ads}) @@ -23238,7 +23499,7 @@ and annotations, so that they can be removed from the final executable. The specification of this unit is compatible with SPARK 2014. @node Ada Containers Functional_Sets a-cofuse ads,Ada Containers Functional_Maps a-cofuma ads,Ada Containers Functional_Vectors a-cofuve ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f0} +@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f2} @section @code{Ada.Containers.Functional_Sets} (@code{a-cofuse.ads}) @@ -23260,7 +23521,7 @@ and annotations, so that they can be removed from the final executable. The specification of this unit is compatible with SPARK 2014. @node Ada Containers Functional_Maps a-cofuma ads,Ada Containers Bounded_Holders a-coboho ads,Ada Containers Functional_Sets a-cofuse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f2} +@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f4} @section @code{Ada.Containers.Functional_Maps} (@code{a-cofuma.ads}) @@ -23282,7 +23543,7 @@ and annotations, so that they can be removed from the final executable. The specification of this unit is compatible with SPARK 2014. @node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Containers Functional_Maps a-cofuma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f4} +@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f6} @section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads}) @@ -23294,7 +23555,7 @@ This child of @code{Ada.Containers} defines a modified version of Indefinite_Holders that avoids heap allocation. @node Ada Command_Line Environment a-colien ads,Ada Command_Line Remove a-colire ads,Ada Containers Bounded_Holders a-coboho ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f6} +@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f8} @section @code{Ada.Command_Line.Environment} (@code{a-colien.ads}) @@ -23307,7 +23568,7 @@ provides a mechanism for obtaining environment values on systems where this concept makes sense. @node Ada Command_Line Remove a-colire ads,Ada Command_Line Response_File a-clrefi ads,Ada Command_Line Environment a-colien ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id19}@anchor{2f8} +@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id19}@anchor{2fa} @section @code{Ada.Command_Line.Remove} (@code{a-colire.ads}) @@ -23325,7 +23586,7 @@ to further calls on the subprograms in @code{Ada.Command_Line} will not see the removed argument. @node Ada Command_Line Response_File a-clrefi ads,Ada Direct_IO C_Streams a-diocst ads,Ada Command_Line Remove a-colire ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fa} +@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fc} @section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads}) @@ -23345,7 +23606,7 @@ Using a response file allow passing a set of arguments to an executable longer than the maximum allowed by the system on the command line. @node Ada Direct_IO C_Streams a-diocst ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Command_Line Response_File a-clrefi ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id21}@anchor{2fc} +@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id21}@anchor{2fe} @section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads}) @@ -23360,7 +23621,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 Exceptions Is_Null_Occurrence a-einuoc ads,Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Direct_IO C_Streams a-diocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id22}@anchor{2fe} +@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id22}@anchor{300} @section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads}) @@ -23374,7 +23635,7 @@ exception occurrence (@code{Null_Occurrence}) without raising an exception. @node Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Exceptions Traceback a-exctra ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id23}@anchor{300} +@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id23}@anchor{302} @section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads}) @@ -23388,7 +23649,7 @@ exceptions (hence the name last chance), and perform clean ups before terminating the program. Note that this subprogram never returns. @node Ada Exceptions Traceback a-exctra ads,Ada Sequential_IO C_Streams a-siocst ads,Ada Exceptions Last_Chance_Handler a-elchha ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id24}@anchor{302} +@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id24}@anchor{304} @section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads}) @@ -23401,7 +23662,7 @@ give a traceback array of addresses based on an exception occurrence. @node Ada Sequential_IO C_Streams a-siocst ads,Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Exceptions Traceback a-exctra ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id25}@anchor{304} +@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id25}@anchor{306} @section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads}) @@ -23416,7 +23677,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 Streams Stream_IO C_Streams a-ssicst ads,Ada Strings Unbounded Text_IO a-suteio ads,Ada Sequential_IO C_Streams a-siocst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id26}@anchor{306} +@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id26}@anchor{308} @section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads}) @@ -23431,7 +23692,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 Strings Unbounded Text_IO a-suteio ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Streams Stream_IO C_Streams a-ssicst ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id27}@anchor{308} +@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{309}@anchor{gnat_rm/the_gnat_library id27}@anchor{30a} @section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads}) @@ -23448,7 +23709,7 @@ strings, avoiding the necessity for an intermediate operation with ordinary strings. @node Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Strings Unbounded Text_IO a-suteio ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{309}@anchor{gnat_rm/the_gnat_library id28}@anchor{30a} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id28}@anchor{30c} @section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads}) @@ -23465,7 +23726,7 @@ 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 Task_Initialization a-tasini ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id29}@anchor{30c} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id29}@anchor{30e} @section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads}) @@ -23482,7 +23743,7 @@ wide wide strings, avoiding the necessity for an intermediate operation with ordinary wide wide strings. @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{30d}@anchor{gnat_rm/the_gnat_library id30}@anchor{30e} +@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id30}@anchor{310} @section @code{Ada.Task_Initialization} (@code{a-tasini.ads}) @@ -23494,7 +23755,7 @@ 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{30f}@anchor{gnat_rm/the_gnat_library id31}@anchor{310} +@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id31}@anchor{312} @section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads}) @@ -23509,7 +23770,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{311}@anchor{gnat_rm/the_gnat_library id32}@anchor{312} +@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id32}@anchor{314} @section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads}) @@ -23524,7 +23785,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 ada-wide-characters-unicode-a-wichun-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id33}@anchor{314} +@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id33}@anchor{316} @section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads}) @@ -23537,7 +23798,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{315}@anchor{gnat_rm/the_gnat_library id34}@anchor{316} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{317}@anchor{gnat_rm/the_gnat_library id34}@anchor{318} @section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads}) @@ -23552,7 +23813,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{317}@anchor{gnat_rm/the_gnat_library id35}@anchor{318} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id35}@anchor{31a} @section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads}) @@ -23567,7 +23828,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 ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id36}@anchor{31a} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id36}@anchor{31c} @section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads}) @@ -23580,7 +23841,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 ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id37}@anchor{31c} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id37}@anchor{31e} @section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads}) @@ -23595,7 +23856,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 ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id38}@anchor{31e} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id38}@anchor{320} @section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads}) @@ -23610,7 +23871,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{31f}@anchor{gnat_rm/the_gnat_library id39}@anchor{320} +@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id39}@anchor{322} @section @code{GNAT.Altivec} (@code{g-altive.ads}) @@ -23623,7 +23884,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{321}@anchor{gnat_rm/the_gnat_library id40}@anchor{322} +@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id40}@anchor{324} @section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads}) @@ -23634,7 +23895,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{323}@anchor{gnat_rm/the_gnat_library id41}@anchor{324} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id41}@anchor{326} @section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads}) @@ -23648,7 +23909,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{325}@anchor{gnat_rm/the_gnat_library id42}@anchor{326} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id42}@anchor{328} @section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads}) @@ -23660,7 +23921,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{327}@anchor{gnat_rm/the_gnat_library id43}@anchor{328} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id43}@anchor{32a} @section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads}) @@ -23675,7 +23936,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{329}@anchor{gnat_rm/the_gnat_library id44}@anchor{32a} +@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id44}@anchor{32c} @section @code{GNAT.Array_Split} (@code{g-arrspl.ads}) @@ -23688,7 +23949,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 gnat-awk-g-awk-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id45}@anchor{32c} +@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id45}@anchor{32e} @section @code{GNAT.AWK} (@code{g-awk.ads}) @@ -23703,7 +23964,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{32d}@anchor{gnat_rm/the_gnat_library id46}@anchor{32e} +@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id46}@anchor{330} @section @code{GNAT.Bind_Environment} (@code{g-binenv.ads}) @@ -23716,7 +23977,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 gnat-branch-prediction-g-brapre-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id47}@anchor{330} +@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id47}@anchor{332} @section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads}) @@ -23727,7 +23988,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 gnat-bounded-buffers-g-boubuf-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id48}@anchor{332} +@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id48}@anchor{334} @section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads}) @@ -23742,7 +24003,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{333}@anchor{gnat_rm/the_gnat_library id49}@anchor{334} +@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id49}@anchor{336} @section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads}) @@ -23755,7 +24016,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{335}@anchor{gnat_rm/the_gnat_library id50}@anchor{336} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id50}@anchor{338} @section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads}) @@ -23770,7 +24031,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 gnat-bubble-sort-a-g-busora-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id51}@anchor{338} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id51}@anchor{33a} @section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads}) @@ -23786,7 +24047,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{339}@anchor{gnat_rm/the_gnat_library id52}@anchor{33a} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id52}@anchor{33c} @section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads}) @@ -23802,7 +24063,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{33b}@anchor{gnat_rm/the_gnat_library id53}@anchor{33c} +@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id53}@anchor{33e} @section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads}) @@ -23818,7 +24079,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{33d}@anchor{gnat_rm/the_gnat_library id54}@anchor{33e} +@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id54}@anchor{340} @section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads}) @@ -23832,7 +24093,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 gnat-calendar-g-calend-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id55}@anchor{340} +@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id55}@anchor{342} @section @code{GNAT.Calendar} (@code{g-calend.ads}) @@ -23846,7 +24107,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 gnat-calendar-time-io-g-catiio-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id56}@anchor{342} +@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id56}@anchor{344} @section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads}) @@ -23857,7 +24118,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 gnat-crc32-g-crc32-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id57}@anchor{344} +@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id57}@anchor{346} @section @code{GNAT.CRC32} (@code{g-crc32.ads}) @@ -23874,7 +24135,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 gnat-case-util-g-casuti-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id58}@anchor{346} +@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id58}@anchor{348} @section @code{GNAT.Case_Util} (@code{g-casuti.ads}) @@ -23889,7 +24150,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 gnat-cgi-g-cgi-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id59}@anchor{348} +@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id59}@anchor{34a} @section @code{GNAT.CGI} (@code{g-cgi.ads}) @@ -23904,7 +24165,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{349}@anchor{gnat_rm/the_gnat_library id60}@anchor{34a} +@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id60}@anchor{34c} @section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads}) @@ -23919,7 +24180,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{34b}@anchor{gnat_rm/the_gnat_library id61}@anchor{34c} +@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id61}@anchor{34e} @section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads}) @@ -23931,7 +24192,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 gnat-command-line-g-comlin-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id62}@anchor{34e} +@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{34f}@anchor{gnat_rm/the_gnat_library id62}@anchor{350} @section @code{GNAT.Command_Line} (@code{g-comlin.ads}) @@ -23944,7 +24205,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{34f}@anchor{gnat_rm/the_gnat_library id63}@anchor{350} +@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id63}@anchor{352} @section @code{GNAT.Compiler_Version} (@code{g-comver.ads}) @@ -23962,7 +24223,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{351}@anchor{gnat_rm/the_gnat_library id64}@anchor{352} +@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id64}@anchor{354} @section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads}) @@ -23973,7 +24234,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 gnat-current-exception-g-curexc-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id65}@anchor{354} +@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id65}@anchor{356} @section @code{GNAT.Current_Exception} (@code{g-curexc.ads}) @@ -23990,7 +24251,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{355}@anchor{gnat_rm/the_gnat_library id66}@anchor{356} +@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id66}@anchor{358} @section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads}) @@ -24007,7 +24268,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{357}@anchor{gnat_rm/the_gnat_library id67}@anchor{358} +@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id67}@anchor{35a} @section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads}) @@ -24020,7 +24281,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 gnat-decode-string-g-decstr-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id68}@anchor{35a} +@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id68}@anchor{35c} @section @code{GNAT.Decode_String} (@code{g-decstr.ads}) @@ -24044,7 +24305,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{35b}@anchor{gnat_rm/the_gnat_library id69}@anchor{35c} +@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id69}@anchor{35e} @section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads}) @@ -24065,7 +24326,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 gnat-directory-operations-g-dirope-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id70}@anchor{35e} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id70}@anchor{360} @section @code{GNAT.Directory_Operations} (@code{g-dirope.ads}) @@ -24078,7 +24339,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 gnat-directory-operations-iteration-g-diopit-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id71}@anchor{360} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id71}@anchor{362} @section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads}) @@ -24090,7 +24351,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 gnat-dynamic-htables-g-dynhta-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id72}@anchor{362} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id72}@anchor{364} @section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads}) @@ -24108,7 +24369,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{363}@anchor{gnat_rm/the_gnat_library id73}@anchor{364} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id73}@anchor{366} @section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads}) @@ -24128,7 +24389,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 gnat-encode-string-g-encstr-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id74}@anchor{366} +@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id74}@anchor{368} @section @code{GNAT.Encode_String} (@code{g-encstr.ads}) @@ -24150,7 +24411,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{367}@anchor{gnat_rm/the_gnat_library id75}@anchor{368} +@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id75}@anchor{36a} @section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads}) @@ -24171,7 +24432,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{369}@anchor{gnat_rm/the_gnat_library id76}@anchor{36a} +@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id76}@anchor{36c} @section @code{GNAT.Exception_Actions} (@code{g-excact.ads}) @@ -24184,7 +24445,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{36b}@anchor{gnat_rm/the_gnat_library id77}@anchor{36c} +@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id77}@anchor{36e} @section @code{GNAT.Exception_Traces} (@code{g-exctra.ads}) @@ -24198,7 +24459,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 gnat-exceptions-g-except-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id78}@anchor{36e} +@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id78}@anchor{370} @section @code{GNAT.Exceptions} (@code{g-except.ads}) @@ -24219,7 +24480,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 gnat-expect-g-expect-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id79}@anchor{370} +@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id79}@anchor{372} @section @code{GNAT.Expect} (@code{g-expect.ads}) @@ -24235,7 +24496,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 gnat-expect-tty-g-exptty-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id80}@anchor{372} +@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id80}@anchor{374} @section @code{GNAT.Expect.TTY} (@code{g-exptty.ads}) @@ -24247,7 +24508,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 gnat-float-control-g-flocon-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id81}@anchor{374} +@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id81}@anchor{376} @section @code{GNAT.Float_Control} (@code{g-flocon.ads}) @@ -24261,7 +24522,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 gnat-formatted-string-g-forstr-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id82}@anchor{376} +@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id82}@anchor{378} @section @code{GNAT.Formatted_String} (@code{g-forstr.ads}) @@ -24276,7 +24537,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{377}@anchor{gnat_rm/the_gnat_library id83}@anchor{378} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id83}@anchor{37a} @section @code{GNAT.Heap_Sort} (@code{g-heasor.ads}) @@ -24290,7 +24551,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 gnat-heap-sort-a-g-hesora-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id84}@anchor{37a} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id84}@anchor{37c} @section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads}) @@ -24306,7 +24567,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 gnat-heap-sort-g-g-hesorg-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id85}@anchor{37c} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id85}@anchor{37e} @section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads}) @@ -24320,7 +24581,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 gnat-htable-g-htable-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id86}@anchor{37e} +@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id86}@anchor{380} @section @code{GNAT.HTable} (@code{g-htable.ads}) @@ -24333,7 +24594,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 gnat-io-g-io-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id87}@anchor{380} +@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id87}@anchor{382} @section @code{GNAT.IO} (@code{g-io.ads}) @@ -24349,7 +24610,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 gnat-io-aux-g-io-aux-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id88}@anchor{382} +@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id88}@anchor{384} @section @code{GNAT.IO_Aux} (@code{g-io_aux.ads}) @@ -24363,7 +24624,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 gnat-lock-files-g-locfil-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id89}@anchor{384} +@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id89}@anchor{386} @section @code{GNAT.Lock_Files} (@code{g-locfil.ads}) @@ -24377,7 +24638,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 gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id90}@anchor{386} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{387}@anchor{gnat_rm/the_gnat_library id90}@anchor{388} @section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads}) @@ -24389,7 +24650,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 gnat-mbbs-float-random-g-mbflra-ads}@anchor{387}@anchor{gnat_rm/the_gnat_library id91}@anchor{388} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id91}@anchor{38a} @section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads}) @@ -24401,7 +24662,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 gnat-md5-g-md5-ads}@anchor{389}@anchor{gnat_rm/the_gnat_library id92}@anchor{38a} +@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id92}@anchor{38c} @section @code{GNAT.MD5} (@code{g-md5.ads}) @@ -24414,7 +24675,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 gnat-memory-dump-g-memdum-ads}@anchor{38b}@anchor{gnat_rm/the_gnat_library id93}@anchor{38c} +@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{38d}@anchor{gnat_rm/the_gnat_library id93}@anchor{38e} @section @code{GNAT.Memory_Dump} (@code{g-memdum.ads}) @@ -24427,7 +24688,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{38d}@anchor{gnat_rm/the_gnat_library id94}@anchor{38e} +@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{38f}@anchor{gnat_rm/the_gnat_library id94}@anchor{390} @section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads}) @@ -24441,7 +24702,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{38f}@anchor{gnat_rm/the_gnat_library id95}@anchor{390} +@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{391}@anchor{gnat_rm/the_gnat_library id95}@anchor{392} @section @code{GNAT.OS_Lib} (@code{g-os_lib.ads}) @@ -24457,7 +24718,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{391}@anchor{gnat_rm/the_gnat_library id96}@anchor{392} +@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{393}@anchor{gnat_rm/the_gnat_library id96}@anchor{394} @section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads}) @@ -24475,7 +24736,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{393}@anchor{gnat_rm/the_gnat_library id97}@anchor{394} +@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{395}@anchor{gnat_rm/the_gnat_library id97}@anchor{396} @section @code{GNAT.Random_Numbers} (@code{g-rannum.ads}) @@ -24487,7 +24748,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{25a}@anchor{gnat_rm/the_gnat_library id98}@anchor{395} +@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{25c}@anchor{gnat_rm/the_gnat_library id98}@anchor{397} @section @code{GNAT.Regexp} (@code{g-regexp.ads}) @@ -24503,7 +24764,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 gnat-registry-g-regist-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id99}@anchor{397} +@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{398}@anchor{gnat_rm/the_gnat_library id99}@anchor{399} @section @code{GNAT.Registry} (@code{g-regist.ads}) @@ -24517,7 +24778,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 gnat-regpat-g-regpat-ads}@anchor{398}@anchor{gnat_rm/the_gnat_library id100}@anchor{399} +@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id100}@anchor{39b} @section @code{GNAT.Regpat} (@code{g-regpat.ads}) @@ -24532,7 +24793,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 gnat-rewrite-data-g-rewdat-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id101}@anchor{39b} +@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id101}@anchor{39d} @section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads}) @@ -24546,7 +24807,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 gnat-secondary-stack-info-g-sestin-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id102}@anchor{39d} +@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id102}@anchor{39f} @section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads}) @@ -24558,7 +24819,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 gnat-semaphores-g-semaph-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id103}@anchor{39f} +@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id103}@anchor{3a1} @section @code{GNAT.Semaphores} (@code{g-semaph.ads}) @@ -24569,7 +24830,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{3a0}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a1} +@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a3} @section @code{GNAT.Serial_Communications} (@code{g-sercom.ads}) @@ -24581,7 +24842,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{3a2}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a3} +@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a5} @section @code{GNAT.SHA1} (@code{g-sha1.ads}) @@ -24594,7 +24855,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{3a4}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a5} +@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a7} @section @code{GNAT.SHA224} (@code{g-sha224.ads}) @@ -24607,7 +24868,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{3a6}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a7} +@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a9} @section @code{GNAT.SHA256} (@code{g-sha256.ads}) @@ -24620,7 +24881,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{3a8}@anchor{gnat_rm/the_gnat_library id108}@anchor{3a9} +@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id108}@anchor{3ab} @section @code{GNAT.SHA384} (@code{g-sha384.ads}) @@ -24633,7 +24894,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 gnat-sha512-g-sha512-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ab} +@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ad} @section @code{GNAT.SHA512} (@code{g-sha512.ads}) @@ -24646,7 +24907,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 gnat-signals-g-signal-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id110}@anchor{3ad} +@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id110}@anchor{3af} @section @code{GNAT.Signals} (@code{g-signal.ads}) @@ -24658,7 +24919,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{3ae}@anchor{gnat_rm/the_gnat_library id111}@anchor{3af} +@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b1} @section @code{GNAT.Sockets} (@code{g-socket.ads}) @@ -24673,7 +24934,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{3b0}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b1} +@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b3} @section @code{GNAT.Source_Info} (@code{g-souinf.ads}) @@ -24687,7 +24948,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 gnat-spelling-checker-g-speche-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b3} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b5} @section @code{GNAT.Spelling_Checker} (@code{g-speche.ads}) @@ -24699,7 +24960,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{3b4}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b5} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3b6}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b7} @section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads}) @@ -24712,7 +24973,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{3b6}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b7} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b9} @section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads}) @@ -24728,7 +24989,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{3b8}@anchor{gnat_rm/the_gnat_library id116}@anchor{3b9} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id116}@anchor{3bb} @section @code{GNAT.Spitbol} (@code{g-spitbo.ads}) @@ -24743,7 +25004,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 gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bb} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bd} @section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads}) @@ -24758,7 +25019,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{3bc}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bd} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bf} @section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads}) @@ -24775,7 +25036,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 gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id119}@anchor{3bf} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id119}@anchor{3c1} @section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads}) @@ -24792,7 +25053,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 gnat-sse-g-sse-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c1} +@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c3} @section @code{GNAT.SSE} (@code{g-sse.ads}) @@ -24804,7 +25065,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{3c2}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c3} +@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c5} @section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads}) @@ -24813,7 +25074,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{3c4}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c5} +@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c7} @section @code{GNAT.String_Hash} (@code{g-strhas.ads}) @@ -24825,7 +25086,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{3c6}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c7} +@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c9} @section @code{GNAT.Strings} (@code{g-string.ads}) @@ -24835,7 +25096,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{3c8}@anchor{gnat_rm/the_gnat_library id124}@anchor{3c9} +@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id124}@anchor{3cb} @section @code{GNAT.String_Split} (@code{g-strspl.ads}) @@ -24849,7 +25110,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 gnat-table-g-table-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id125}@anchor{3cb} +@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id125}@anchor{3cd} @section @code{GNAT.Table} (@code{g-table.ads}) @@ -24869,7 +25130,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 gnat-task-lock-g-tasloc-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id126}@anchor{3cd} +@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id126}@anchor{3cf} @section @code{GNAT.Task_Lock} (@code{g-tasloc.ads}) @@ -24886,7 +25147,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 gnat-time-stamp-g-timsta-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id127}@anchor{3cf} +@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id127}@anchor{3d1} @section @code{GNAT.Time_Stamp} (@code{g-timsta.ads}) @@ -24901,7 +25162,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 gnat-threads-g-thread-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d1} +@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d3} @section @code{GNAT.Threads} (@code{g-thread.ads}) @@ -24918,7 +25179,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 gnat-traceback-g-traceb-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d3} +@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3d4}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d5} @section @code{GNAT.Traceback} (@code{g-traceb.ads}) @@ -24930,7 +25191,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{3d4}@anchor{gnat_rm/the_gnat_library id130}@anchor{3d5} +@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id130}@anchor{3d7} @section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads}) @@ -24939,7 +25200,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 gnat-utf-32-g-table-ads}@anchor{3d6}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d7} +@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d8}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d9} @section @code{GNAT.UTF_32} (@code{g-table.ads}) @@ -24958,7 +25219,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{3d8}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d9} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3da}@anchor{gnat_rm/the_gnat_library id132}@anchor{3db} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads}) @@ -24971,7 +25232,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{3da}@anchor{gnat_rm/the_gnat_library id133}@anchor{3db} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id133}@anchor{3dd} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads}) @@ -24983,7 +25244,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 gnat-wide-string-split-g-wistsp-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id134}@anchor{3dd} +@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3de}@anchor{gnat_rm/the_gnat_library id134}@anchor{3df} @section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads}) @@ -24997,7 +25258,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{3de}@anchor{gnat_rm/the_gnat_library id135}@anchor{3df} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3e0}@anchor{gnat_rm/the_gnat_library id135}@anchor{3e1} @section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads}) @@ -25009,7 +25270,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{3e0}@anchor{gnat_rm/the_gnat_library id136}@anchor{3e1} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3e2}@anchor{gnat_rm/the_gnat_library id136}@anchor{3e3} @section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads}) @@ -25023,7 +25284,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 id137}@anchor{3e2}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3e3} +@anchor{gnat_rm/the_gnat_library id137}@anchor{3e4}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3e5} @section @code{Interfaces.C.Extensions} (@code{i-cexten.ads}) @@ -25034,7 +25295,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 id138}@anchor{3e4}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e5} +@anchor{gnat_rm/the_gnat_library id138}@anchor{3e6}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3e7} @section @code{Interfaces.C.Streams} (@code{i-cstrea.ads}) @@ -25047,7 +25308,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 id139}@anchor{3e6}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e7} +@anchor{gnat_rm/the_gnat_library id139}@anchor{3e8}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e9} @section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads}) @@ -25062,7 +25323,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 id140}@anchor{3e8}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e9} +@anchor{gnat_rm/the_gnat_library id140}@anchor{3ea}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3eb} @section @code{Interfaces.VxWorks} (@code{i-vxwork.ads}) @@ -25078,7 +25339,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 id141}@anchor{3ea}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3eb} +@anchor{gnat_rm/the_gnat_library id141}@anchor{3ec}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3ed} @section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads}) @@ -25094,7 +25355,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 id142}@anchor{3ec}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3ed} +@anchor{gnat_rm/the_gnat_library id142}@anchor{3ee}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3ef} @section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads}) @@ -25117,7 +25378,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 id143}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3ef} +@anchor{gnat_rm/the_gnat_library id143}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3f1} @section @code{System.Address_Image} (@code{s-addima.ads}) @@ -25133,7 +25394,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 id144}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3f1} +@anchor{gnat_rm/the_gnat_library id144}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3f3} @section @code{System.Assertions} (@code{s-assert.ads}) @@ -25149,7 +25410,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 id145}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f3} +@anchor{gnat_rm/the_gnat_library id145}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3f5} @section @code{System.Atomic_Counters} (@code{s-atocou.ads}) @@ -25163,7 +25424,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 id146}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f5} +@anchor{gnat_rm/the_gnat_library id146}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3f7} @section @code{System.Memory} (@code{s-memory.ads}) @@ -25181,7 +25442,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 id147}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f7} +@anchor{gnat_rm/the_gnat_library id147}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f9} @section @code{System.Multiprocessors} (@code{s-multip.ads}) @@ -25194,7 +25455,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 id148}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f9} +@anchor{gnat_rm/the_gnat_library id148}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3fb} @section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads}) @@ -25207,7 +25468,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 id149}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3fb} +@anchor{gnat_rm/the_gnat_library id149}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3fd} @section @code{System.Partition_Interface} (@code{s-parint.ads}) @@ -25220,7 +25481,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 id150}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3fd} +@anchor{gnat_rm/the_gnat_library id150}@anchor{3fe}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3ff} @section @code{System.Pool_Global} (@code{s-pooglo.ads}) @@ -25237,7 +25498,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 id151}@anchor{3fe}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3ff} +@anchor{gnat_rm/the_gnat_library id151}@anchor{400}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{401} @section @code{System.Pool_Local} (@code{s-pooloc.ads}) @@ -25254,7 +25515,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 id152}@anchor{400}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{401} +@anchor{gnat_rm/the_gnat_library id152}@anchor{402}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{403} @section @code{System.Restrictions} (@code{s-restri.ads}) @@ -25270,7 +25531,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 id153}@anchor{402}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{403} +@anchor{gnat_rm/the_gnat_library id153}@anchor{404}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{405} @section @code{System.Rident} (@code{s-rident.ads}) @@ -25286,7 +25547,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 id154}@anchor{404}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{405} +@anchor{gnat_rm/the_gnat_library id154}@anchor{406}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{407} @section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads}) @@ -25302,7 +25563,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 id155}@anchor{406}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{407} +@anchor{gnat_rm/the_gnat_library id155}@anchor{408}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{409} @section @code{System.Unsigned_Types} (@code{s-unstyp.ads}) @@ -25315,7 +25576,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 id156}@anchor{408}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{409} +@anchor{gnat_rm/the_gnat_library id156}@anchor{40a}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{40b} @section @code{System.Wch_Cnv} (@code{s-wchcnv.ads}) @@ -25336,7 +25597,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 id157}@anchor{40a}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{40b} +@anchor{gnat_rm/the_gnat_library id157}@anchor{40c}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{40d} @section @code{System.Wch_Con} (@code{s-wchcon.ads}) @@ -25348,7 +25609,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 doc}@anchor{40c}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{40d}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11} +@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{40e}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{40f}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11} @chapter Interfacing to Other Languages @@ -25366,7 +25627,7 @@ provided. @end menu @node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{40e}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{40f} +@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{410}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{411} @section Interfacing to C @@ -25506,7 +25767,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 id3}@anchor{47}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{410} +@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{48}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{412} @section Interfacing to C++ @@ -25563,7 +25824,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{411}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{412} +@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{413}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{414} @section Interfacing to COBOL @@ -25571,7 +25832,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{413}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{414} +@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{415}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{416} @section Interfacing to Fortran @@ -25581,7 +25842,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 id7}@anchor{415}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{416} +@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{417}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{418} @section Interfacing to non-GNAT Ada code @@ -25605,7 +25866,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 doc}@anchor{417}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{418}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12} +@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{419}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{41a}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12} @chapter Specialized Needs Annexes @@ -25646,7 +25907,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 doc}@anchor{419}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{41a}@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{41b}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13} @chapter Implementation of Specific Ada Features @@ -25665,7 +25926,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 id2}@anchor{41b}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{166} +@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{41d}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{167} @section Machine Code Insertions @@ -25833,7 +26094,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 gnat-implementation-of-tasking}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{41d} +@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{41e}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{41f} @section GNAT Implementation of Tasking @@ -25849,7 +26110,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 id4}@anchor{41e}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{41f} +@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{420}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{421} @subsection Mapping Ada Tasks onto the Underlying Kernel Threads @@ -25918,7 +26179,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 ensuring-compliance-with-the-real-time-annex}@anchor{420}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{421} +@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{422}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{423} @subsection Ensuring Compliance with the Real-Time Annex @@ -25969,7 +26230,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{422} +@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{424} @subsection Support for Locking Policies @@ -26003,7 +26264,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 gnat-implementation-of-shared-passive-packages}@anchor{423}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{424} +@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{425}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{426} @section GNAT Implementation of Shared Passive Packages @@ -26101,7 +26362,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{425}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{426} +@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{428} @section Code Generation for Array Aggregates @@ -26132,7 +26393,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 id8}@anchor{427}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{428} +@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{429}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{42a} @subsection Static constant aggregates with static bounds @@ -26179,7 +26440,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{429}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{42a} +@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{42b}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{42c} @subsection Constant aggregates with unconstrained nominal types @@ -26194,7 +26455,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 aggregates-with-static-bounds}@anchor{42b}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{42c} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{42d}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{42e} @subsection Aggregates with static bounds @@ -26222,7 +26483,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 aggregates-with-nonstatic-bounds}@anchor{42d}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{42e} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{430} @subsection Aggregates with nonstatic bounds @@ -26233,7 +26494,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 aggregates-in-assignment-statements}@anchor{42f}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{430} +@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{431}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{432} @subsection Aggregates in assignment statements @@ -26275,7 +26536,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,Image Values For Nonscalar Types,Code Generation for Array Aggregates,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{431}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{432} +@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{433}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{434} @section The Size of Discriminated Records with Default Discriminants @@ -26355,7 +26616,7 @@ say) must be consistent, so it is imperative that the object, once created, remain invariant. @node Image Values For Nonscalar Types,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 id14}@anchor{433}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{434} +@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{435}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{436} @section Image Values For Nonscalar Types @@ -26375,7 +26636,7 @@ control of image text is required for some type T, then T’Put_Image should be explicitly specified. @node Strict Conformance to the Ada Reference Manual,,Image Values For Nonscalar Types,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{435}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{436} +@anchor{gnat_rm/implementation_of_specific_ada_features id15}@anchor{437}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{438} @section Strict Conformance to the Ada Reference Manual @@ -26401,8 +26662,8 @@ machines that are not fully compliant with this standard, such as Alpha, the 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{437}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{438}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14} +@node Implementation of Ada 2012 Features,Security Hardening Features,Implementation of Specific Ada Features,Top +@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{439}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{43a}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14} @chapter Implementation of Ada 2012 Features @@ -28567,8 +28828,102 @@ where the type of the returned value is an anonymous access type. 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 doc}@anchor{439}@anchor{gnat_rm/obsolescent_features id1}@anchor{43a}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15} +@node Security Hardening Features,Obsolescent Features,Implementation of Ada 2012 Features,Top +@anchor{gnat_rm/security_hardening_features doc}@anchor{43b}@anchor{gnat_rm/security_hardening_features id1}@anchor{43c}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@chapter Security Hardening Features + + +This chapter describes Ada extensions aimed at security hardening that +are provided by GNAT. + +@c Register Scrubbing: + +@menu +* Register Scrubbing:: +* Stack Scrubbing:: + +@end menu + +@node Register Scrubbing,Stack Scrubbing,,Security Hardening Features +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{43d} +@section Register Scrubbing + + +GNAT can generate code to zero-out hardware registers before returning +from a subprogram. + +It can be enabled with the @emph{-fzero-call-used-regs} command line +option, to affect all subprograms in a compilation, and with a +@code{Machine_Attribute} pragma, to affect only specific subprograms. + +@example +procedure Foo; +pragma Machine_Attribute (Foo, "zero_call_used_regs", "used"); +-- Before returning, Foo scrubs only call-clobbered registers +-- that it uses itself. + +function Bar return Integer; +pragma Machine_Attribute (Bar, "zero_call_used_regs", "all"); +-- Before returning, Bar scrubs all call-clobbered registers. +@end example + +For usage and more details on the command line option, and on the +@code{zero_call_used_regs} attribute, see @cite{Using the GNU Compiler Collection (GCC)}. + +@c Stack Scrubbing: + +@node Stack Scrubbing,,Register Scrubbing,Security Hardening Features +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{43e} +@section Stack Scrubbing + + +GNAT can generate code to zero-out stack frames used by subprograms. + +It can be activated with the @code{Machine_Attribute} pragma, on +specific subprograms and variables. + +@example +function Foo returns Integer; +pragma Machine_Attribute (Foo, "strub"); +-- Foo and its callers are modified so as to scrub the stack +-- space used by Foo after it returns. + +procedure Bar; +pragma Machine_Attribute (Bar, "strub", "internal"); +-- Bar is turned into a wrapper for its original body, +-- and they scrub the stack used by the original body. + +Var : Integer; +pragma Machine_Attribute (Var, "strub"); +-- Reading from Var in a subprogram enables stack scrubbing +-- of the stack space used by the subprogram. +@end example + +There are also @emph{-fstrub} command line options to control default +settings. For usage and more details on the command line option, and +on the @code{strub} attribute, see @cite{Using the GNU Compiler Collection (GCC)}. + +Note that Ada secondary stacks are not scrubbed. The restriction +@code{No_Secondary_Stack} avoids their use, and thus their accidental +preservation of data that should be scrubbed. + +Also note that the machine attribute is not integrated in the Ada type +system. Though it may modify subprogram and variable interfaces, it +is not fully reflected in Ada types, @code{Access} attributes, renaming +and overriding. Every access type, renaming, and overriding and +overridden dispatching operations that may refer to an entity with an +attribute-modified interface must be annotated with the same +interface-modifying attribute, or with an interface-compatible one. + +Even then, the pragma is currently only functional when applied to +subprograms and scalar variables; other uses, such as directly on +types and subtypes, may be silently ignored. Specifically, it is not +currently recommended to rely on any effects this pragma might be +expected to have when calling subprograms through access-to-subprogram +variables. + +@node Obsolescent Features,Compatibility and Porting Guide,Security Hardening Features,Top +@anchor{gnat_rm/obsolescent_features doc}@anchor{43f}@anchor{gnat_rm/obsolescent_features id1}@anchor{440}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -28587,7 +28942,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{43b}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{43c} +@anchor{gnat_rm/obsolescent_features id2}@anchor{441}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{442} @section pragma No_Run_Time @@ -28600,7 +28955,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{43d}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{43e} +@anchor{gnat_rm/obsolescent_features id3}@anchor{443}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{444} @section pragma Ravenscar @@ -28609,7 +28964,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 id4}@anchor{43f}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{440} +@anchor{gnat_rm/obsolescent_features id4}@anchor{445}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{446} @section pragma Restricted_Run_Time @@ -28619,7 +28974,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 id5}@anchor{441}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{442} +@anchor{gnat_rm/obsolescent_features id5}@anchor{447}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{448} @section pragma Task_Info @@ -28645,7 +29000,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{443}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{444} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{449}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{44a} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -28655,7 +29010,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 doc}@anchor{445}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{446} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{44b}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{44c} @chapter Compatibility and Porting Guide @@ -28677,7 +29032,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{447}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{448} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{44d}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{44e} @section Writing Portable Fixed-Point Declarations @@ -28799,7 +29154,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{449}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{44a} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{44f}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{450} @section Compatibility with Ada 83 @@ -28827,7 +29182,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{44b}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{44c} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{451}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{452} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -28927,7 +29282,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 id5}@anchor{44d}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{44e} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{453}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{454} @subsection More deterministic semantics @@ -28955,7 +29310,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 changed-semantics}@anchor{44f}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{450} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{455}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{456} @subsection Changed semantics @@ -28997,7 +29352,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 id7}@anchor{451}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{452} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{458} @subsection Other language compatibility issues @@ -29030,7 +29385,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{453}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{454} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{45a} @section Compatibility between Ada 95 and Ada 2005 @@ -29102,7 +29457,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 id9}@anchor{455}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{456} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{45c} @section Implementation-dependent characteristics @@ -29125,7 +29480,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 id10}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{458} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{45d}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{45e} @subsection Implementation-defined pragmas @@ -29147,7 +29502,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{459}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{45a} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{45f}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{460} @subsection Implementation-defined attributes @@ -29161,7 +29516,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 id12}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{45c} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{461}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{462} @subsection Libraries @@ -29190,7 +29545,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{45d}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{45e} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{463}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{464} @subsection Elaboration order @@ -29226,7 +29581,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 id14}@anchor{45f}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{460} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{465}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{466} @subsection Target-specific aspects @@ -29239,10 +29594,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{461,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{467,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{462}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{463} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{468}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{469} @section Compatibility with Other Ada Systems @@ -29285,7 +29640,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 id16}@anchor{464}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{461} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{46a}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{467} @section Representation Clauses @@ -29378,7 +29733,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{465}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{466} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{46b}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{46c} @section Compatibility with HP Ada 83 @@ -29408,7 +29763,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license doc}@anchor{467}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{468} +@anchor{share/gnu_free_documentation_license doc}@anchor{46d}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{46e} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 9919cad..28f2f19 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 , Aug 03, 2021 +GNAT User's Guide for Native Platforms , Sep 28, 2021 AdaCore @@ -2814,16 +2814,12 @@ C_Pass_By_Copy Check_Float_Overflow Check_Name Check_Policy -Compile_Time_Error -Compile_Time_Warning -Compiler_Unit -Compiler_Unit_Warning Component_Alignment Convention_Identifier Debug_Policy -Detect_Blocking Default_Scalar_Storage_Order Default_Storage_Pool +Detect_Blocking Disable_Atomic_Synchronization Discard_Names Elaboration_Checks @@ -2842,7 +2838,6 @@ License Locking_Policy No_Component_Reordering No_Heap_Finalization -No_Run_Time No_Strict_Aliasing Normalize_Scalars Optimize_Alignment @@ -2854,17 +2849,12 @@ Prefix_Exception_Messages Priority_Specific_Dispatching Profile Profile_Warnings -Propagate_Exceptions Queuing_Policy -Rational -Ravenscar Rename_Pragma -Restricted_Run_Time Restrictions -Restrictions_Warnings +Restriction_Warnings Reviewable Short_Circuit_And_Or -Short_Descriptors Source_File_Name Source_File_Name_Project SPARK_Mode @@ -2873,7 +2863,6 @@ Suppress Suppress_Exception_Locations Task_Dispatching_Policy Unevaluated_Use_Of_Old -Universal_Data Unsuppress Use_VADS_Size Validity_Checks @@ -2925,7 +2914,7 @@ only to the unit in which the pragma appears, and not to any other units. The exception is No_Elaboration_Code which always applies to the entire object file from a compilation, i.e. to the body, spec, and all subunits. This restriction can be specified in a configuration pragma file, or it -can be on the body and/or the spec (in eithe case it applies to all the +can be on the body and/or the spec (in either case it applies to all the relevant units). It can appear on a subunit only if it has previously appeared in the body of spec. @@ -6421,10 +6410,10 @@ as comments, to be completed manually if needed. some extensions (e.g. vector types) are not supported @item -pointers to pointers or complex structures are mapped to System.Address +pointers to pointers are mapped to System.Address @item -identifiers with identical name (except casing) will generate compilation +identifiers with identical name (except casing) may generate compilation errors (e.g. @code{shm_get} vs @code{SHM_GET}). @end itemize @@ -6450,15 +6439,18 @@ spec files for the header files specified on the command line, and all header files needed by these files transitively. For example: @example -$ g++ -c -fdump-ada-spec -C /usr/include/time.h +$ gcc -c -fdump-ada-spec -C /usr/include/time.h $ gcc -c *.ads @end example will generate, under GNU/Linux, the following files: @code{time_h.ads}, @code{bits_time_h.ads}, @code{stddef_h.ads}, @code{bits_types_h.ads} which correspond to the files @code{/usr/include/time.h}, -@code{/usr/include/bits/time.h}, etc…, and will then compile these Ada specs -in Ada 2005 mode. +@code{/usr/include/bits/time.h}, etc…, and then compile these Ada specs. +That is to say, the name of the Ada specs is in keeping with the relative path +under @code{/usr/include/} of the header files. This behavior is specific to +paths ending with @code{/include/}; in all the other cases, the name of the +Ada specs is derived from the simple name of the header files instead. The @code{-C} switch tells @code{gcc} to extract comments from headers, and will attempt to generate corresponding Ada comments. @@ -6469,46 +6461,15 @@ can use instead the @code{-fdump-ada-spec-slim} switch. You can optionally specify a parent unit, of which all generated units will be children, using @code{-fada-spec-parent=@emph{unit}}. -Note that we recommend when possible to use the @emph{g++} driver to -generate bindings, even for most C headers, since this will in general -generate better Ada specs. For generating bindings for C++ headers, it is -mandatory to use the @emph{g++} command, or @emph{gcc -x c++} which -is equivalent in this case. If @emph{g++} cannot work on your C headers -because of incompatibilities between C and C++, then you can fallback to -@code{gcc} instead. - -For an example of better bindings generated from the C++ front-end, -the name of the parameters (when available) are actually ignored by the C -front-end. Consider the following C header: - -@example -extern void foo (int variable); -@end example - -with the C front-end, @code{variable} is ignored, and the above is handled as: - -@example -extern void foo (int); -@end example - -generating a generic: - -@example -procedure foo (param1 : int); -@end example - -with the C++ front-end, the name is available, and we generate: - -@example -procedure foo (variable : int); -@end example +The simple @code{gcc`}-based command works only for C headers. For C++ headers +you need to use either the @code{g++} command or the combination @code{gcc -x c++`}. In some cases, the generated bindings will be more complete or more meaningful when defining some macros, which you can do via the @code{-D} switch. This is for example the case with @code{Xlib.h} under GNU/Linux: @example -$ g++ -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h +$ gcc -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h @end example The above will generate more complete bindings than a straight call without @@ -6530,7 +6491,7 @@ lines in e.g. @code{readline1.h}: and then generate Ada bindings from this file: @example -$ g++ -c -fdump-ada-spec readline1.h +$ gcc -c -fdump-ada-spec readline1.h @end example @node Generating Bindings for C++ Headers,Switches,Running the Binding Generator,Generating Ada Bindings for C and C++ headers @@ -6799,7 +6760,7 @@ call subprograms, reference objects, and constants. This section compares the GNAT model with the approaches taken in -other environents, first the C/C++ model and then the mechanism that +other environments, first the C/C++ model and then the mechanism that has been used in other Ada systems, in particular those traditionally used for Ada 83. @@ -8961,9 +8922,10 @@ also suppresses generation of cross-reference information @item @code{-gnateA} Check that the actual parameters of a subprogram call are not aliases of one -another. To qualify as aliasing, the actuals must denote objects of a composite -type, their memory locations must be identical or overlapping, and at least one -of the corresponding formal parameters must be of mode OUT or IN OUT. +another. To qualify as aliasing, their memory locations must be identical or +overlapping, at least one of the corresponding formal parameters must be of +mode OUT or IN OUT, and at least one of the corresponding formal parameters +must have its parameter passing mechanism not specified. @example type Rec_Typ is record @@ -22645,7 +22607,10 @@ Ignore : constant Boolean := @end quotation It gets the effective user id, and if it’s not 0 (i.e. root), it raises -Program_Error. +Program_Error. Note that if you re running the code in a container, this may +not be sufficient, as you may have sufficient priviledge on the container, +but not on the host machine running the container, so check that you also +have sufficient priviledge for running the container image. @geindex Linux diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 5cb2df0..90d8af4 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -125,7 +125,6 @@ procedure Gnatbind is Scan_ALI (F => Std_Lib_File, T => Text, - Ignore_ED => False, Err => False, Ignore_Errors => Debug_Flag_I); @@ -770,7 +769,6 @@ begin Id := Scan_ALI (F => Main_Lib_File, T => Text, - Ignore_ED => False, Err => False, Ignore_Errors => Debug_Flag_I, Directly_Scanned => True); diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index c3fc25e..83bafff 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -347,6 +347,11 @@ procedure Gnatfind is -- Start of processing for Gnatfind begin + Put_Line + ("WARNING: gnatfind is obsolete and will be removed in the next release"); + Put_Line + ("Consider using Libadalang or GNAT Studio python scripting instead"); + Parse_Cmd_Line; if not Have_Entity then diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 52e714a..a321bf3 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1531,7 +1531,6 @@ begin A := Scan_ALI (F, T, - Ignore_ED => False, Err => False, Ignore_Errors => True); diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index 353e36d..c676996 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -2278,7 +2278,6 @@ begin Scan_ALI (Ali_File, Text, - Ignore_ED => False, Err => False, Ignore_Errors => True); end; diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index 9a3935c..3737f66 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -299,6 +299,11 @@ procedure Gnatxref is end Write_Usage; begin + Put_Line + ("WARNING: gnatxref is obsolete and will be removed in the next release"); + Put_Line + ("Consider using Libadalang or GNAT Studio python scripting instead"); + Parse_Cmd_Line; if not Have_File then diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index b99f3fd..5fe1353 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -23,14 +23,14 @@ -- -- ------------------------------------------------------------------------------ -with Errout; use Errout; -with Sinfo; use Sinfo; -with Sinfo.Nodes; use Sinfo.Nodes; -with Fname.UF; use Fname.UF; -with Lib; use Lib; -with Namet; use Namet; -with Opt; use Opt; -with Uname; use Uname; +with Errout; use Errout; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Fname.UF; use Fname.UF; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Uname; use Uname; -- Note: this package body is used by GNAT Studio and GNATBench to supply a -- list of entries for help on available library routines. diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 2bbb601..dbd8516 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2551,6 +2551,7 @@ __gnat_install_handler (void) #include <signal.h> #include <unistd.h> #include <string.h> +#include <errno.h> #include "sigtramp.h" void diff --git a/gcc/ada/libgnarl/a-tasini.adb b/gcc/ada/libgnarl/a-tasini.adb index c0dfe70..a8981d6 100644 --- a/gcc/ada/libgnarl/a-tasini.adb +++ b/gcc/ada/libgnarl/a-tasini.adb @@ -26,13 +26,13 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Conversion; -with System.Tasking; - package body Ada.Task_Initialization is - function To_STIH is new Ada.Unchecked_Conversion - (Initialization_Handler, System.Tasking.Initialization_Handler); + Global_Initialization_Handler : Initialization_Handler := null; + pragma Atomic (Global_Initialization_Handler); + pragma Export (Ada, Global_Initialization_Handler, + "__gnat_global_initialization_handler"); + -- Global handler called when each task initializes. -------------------------------- -- Set_Initialization_Handler -- @@ -40,7 +40,7 @@ package body Ada.Task_Initialization is procedure Set_Initialization_Handler (Handler : Initialization_Handler) is begin - System.Tasking.Global_Initialization_Handler := To_STIH (Handler); + Global_Initialization_Handler := Handler; end Set_Initialization_Handler; end Ada.Task_Initialization; diff --git a/gcc/ada/libgnarl/a-tasini.ads b/gcc/ada/libgnarl/a-tasini.ads index dd2a17c..a754c06 100644 --- a/gcc/ada/libgnarl/a-tasini.ads +++ b/gcc/ada/libgnarl/a-tasini.ads @@ -30,12 +30,17 @@ -- when tasks start. package Ada.Task_Initialization is - pragma Preelaborate (Task_Initialization); + pragma Preelaborate; + pragma No_Elaboration_Code_All; type Initialization_Handler is access procedure; procedure Set_Initialization_Handler (Handler : Initialization_Handler); - -- Set the global task initialization handler to Handler + -- Set the global task initialization handler to Handler. + -- Note that only tasks created after this procedure is called will trigger + -- a call to Handler. You can use Ada's elaboration rules and pragma + -- Elaborate_All, or the pragma Linker_Constructor to ensure this + -- procedure is called early. private pragma Favor_Top_Level (Initialization_Handler); diff --git a/gcc/ada/libgnarl/s-interr__vxworks.adb b/gcc/ada/libgnarl/s-interr__vxworks.adb index d496b74..db2ca95 100644 --- a/gcc/ada/libgnarl/s-interr__vxworks.adb +++ b/gcc/ada/libgnarl/s-interr__vxworks.adb @@ -66,7 +66,6 @@ with Ada.Unchecked_Conversion; with Ada.Task_Identification; -with Interfaces.C; use Interfaces.C; with System.OS_Interface; use System.OS_Interface; with System.Interrupt_Management; with System.Task_Primitives.Operations; @@ -76,12 +75,18 @@ with System.Tasking.Utilities; with System.Tasking.Rendezvous; pragma Elaborate_All (System.Tasking.Rendezvous); +with System.VxWorks.Ext; + package body System.Interrupts is use Tasking; package POP renames System.Task_Primitives.Operations; + use type System.VxWorks.Ext.STATUS; + subtype STATUS is System.VxWorks.Ext.STATUS; + OK : constant STATUS := System.VxWorks.Ext.OK; + function To_Ada is new Ada.Unchecked_Conversion (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id); @@ -199,7 +204,7 @@ package body System.Interrupts is type Interrupt_Connector is access function (Vector : Interrupt_Vector; Handler : Interrupt_Handler; - Parameter : System.Address := System.Null_Address) return int; + Parameter : System.Address := System.Null_Address) return STATUS; -- Profile must match VxWorks intConnect() Interrupt_Connect : Interrupt_Connector := @@ -515,7 +520,7 @@ package body System.Interrupts is Vec : constant Interrupt_Vector := Interrupt_Number_To_Vector (int (Interrupt)); - Status : int; + Result : STATUS; begin -- Only install umbrella handler when no Ada handler has already been @@ -525,9 +530,9 @@ package body System.Interrupts is -- number. if not Handler_Installed (Interrupt) then - Status := + Result := Interrupt_Connect.all (Vec, Handler, System.Address (Interrupt)); - pragma Assert (Status = 0); + pragma Assert (Result = OK); Handler_Installed (Interrupt) := True; end if; @@ -646,11 +651,11 @@ package body System.Interrupts is procedure Notify_Interrupt (Param : System.Address) is Interrupt : constant Interrupt_ID := Interrupt_ID (Param); Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt); - Status : int; + Result : STATUS; begin if Id /= 0 then - Status := Binary_Semaphore_Release (Id); - pragma Assert (Status = 0); + Result := Binary_Semaphore_Release (Id); + pragma Assert (Result = OK); end if; end Notify_Interrupt; @@ -787,13 +792,13 @@ package body System.Interrupts is -------------------- procedure Unbind_Handler (Interrupt : Interrupt_ID) is - Status : int; + Result : STATUS; begin -- Flush server task off semaphore, allowing it to terminate - Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt)); - pragma Assert (Status = 0); + Result := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt)); + pragma Assert (Result = OK); end Unbind_Handler; -------------------------------- @@ -1067,7 +1072,7 @@ package body System.Interrupts is Tmp_Handler : Parameterless_Handler; Tmp_ID : Task_Id; Tmp_Entry_Index : Task_Entry_Index; - Status : int; + Result : STATUS; begin Semaphore_ID_Map (Interrupt) := Int_Sema; @@ -1076,8 +1081,8 @@ package body System.Interrupts is -- Pend on semaphore that will be triggered by the umbrella handler -- when the associated interrupt comes in. - Status := Binary_Semaphore_Obtain (Int_Sema); - pragma Assert (Status = 0); + Result := Binary_Semaphore_Obtain (Int_Sema); + pragma Assert (Result = OK); if User_Handler (Interrupt).H /= null then @@ -1109,9 +1114,9 @@ package body System.Interrupts is -- Delete the associated semaphore - Status := Binary_Semaphore_Delete (Int_Sema); + Result := Binary_Semaphore_Delete (Int_Sema); - pragma Assert (Status = 0); + pragma Assert (Result = OK); -- Set status for the Interrupt_Manager diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.adb b/gcc/ada/libgnarl/s-osinte__vxworks.adb index cf3ece3..fbc8367 100644 --- a/gcc/ada/libgnarl/s-osinte__vxworks.adb +++ b/gcc/ada/libgnarl/s-osinte__vxworks.adb @@ -100,10 +100,11 @@ package body System.OS_Interface is Ticks : Long_Long_Integer; Rate_Duration : Duration; Ticks_Duration : Duration; + IERR : constant int := -1; begin if D < 0.0 then - return ERROR; + return IERR; end if; -- Ensure that the duration can be converted to ticks @@ -142,7 +143,8 @@ package body System.OS_Interface is -- Binary_Semaphore_Delete -- ----------------------------- - function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int is + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) + return STATUS is begin return semDelete (SEM_ID (ID)); end Binary_Semaphore_Delete; @@ -151,7 +153,8 @@ package body System.OS_Interface is -- Binary_Semaphore_Obtain -- ----------------------------- - function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int is + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) + return STATUS is begin return semTake (SEM_ID (ID), WAIT_FOREVER); end Binary_Semaphore_Obtain; @@ -160,7 +163,8 @@ package body System.OS_Interface is -- Binary_Semaphore_Release -- ------------------------------ - function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int is + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) + return STATUS is begin return semGive (SEM_ID (ID)); end Binary_Semaphore_Release; @@ -169,7 +173,7 @@ package body System.OS_Interface is -- Binary_Semaphore_Flush -- ---------------------------- - function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int is + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return STATUS is begin return semFlush (SEM_ID (ID)); end Binary_Semaphore_Flush; @@ -190,7 +194,7 @@ package body System.OS_Interface is function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; - Parameter : System.Address := System.Null_Address) return int is + Parameter : System.Address := System.Null_Address) return STATUS is begin return System.VxWorks.Ext.Interrupt_Connect @@ -203,7 +207,7 @@ package body System.OS_Interface is -- Interrupt_Context -- ----------------------- - function Interrupt_Context return int is + function Interrupt_Context return BOOL is begin return System.VxWorks.Ext.Interrupt_Context; end Interrupt_Context; diff --git a/gcc/ada/libgnarl/s-osinte__vxworks.ads b/gcc/ada/libgnarl/s-osinte__vxworks.ads index a2d5620..e851645 100644 --- a/gcc/ada/libgnarl/s-osinte__vxworks.ads +++ b/gcc/ada/libgnarl/s-osinte__vxworks.ads @@ -47,6 +47,8 @@ with System.Parameters; package System.OS_Interface is pragma Preelaborate; + package SVE renames System.VxWorks.Ext; + subtype int is Interfaces.C.int; subtype unsigned is Interfaces.C.unsigned; subtype short is Short_Integer; @@ -57,6 +59,10 @@ package System.OS_Interface is type unsigned_long_long is mod 2 ** long_long'Size; type size_t is mod 2 ** Standard'Address_Size; + subtype STATUS is SVE.STATUS; + subtype BOOL is SVE.BOOL; + subtype vx_freq_t is SVE.vx_freq_t; + ----------- -- Errno -- ----------- @@ -201,7 +207,7 @@ package System.OS_Interface is oset : access sigset_t) return int; pragma Import (C, pthread_sigmask, "sigprocmask"); - subtype t_id is System.VxWorks.Ext.t_id; + subtype t_id is SVE.t_id; subtype Thread_Id is t_id; -- Thread_Id and t_id are VxWorks identifiers for tasks. This value, -- although represented as a Long_Integer, is in fact an address. With @@ -211,27 +217,24 @@ package System.OS_Interface is function kill (pid : t_id; sig : Signal) return int; pragma Inline (kill); - function getpid return t_id renames System.VxWorks.Ext.getpid; + function getpid return t_id renames SVE.getpid; - function Task_Stop (tid : t_id) return int - renames System.VxWorks.Ext.Task_Stop; + function Task_Stop (tid : t_id) return STATUS renames SVE.Task_Stop; -- If we are in the kernel space, stop the task whose t_id is given in -- parameter in such a way that it can be examined by the debugger. This -- typically maps to taskSuspend on VxWorks 5 and to taskStop on VxWorks 6. - function Task_Cont (tid : t_id) return int - renames System.VxWorks.Ext.Task_Cont; + function Task_Cont (tid : t_id) return STATUS renames SVE.Task_Cont; -- If we are in the kernel space, continue the task whose t_id is given -- in parameter if it has been stopped previously to be examined by the -- debugger (e.g. by taskStop). It typically maps to taskResume on VxWorks -- 5 and to taskCont on VxWorks 6. - function Int_Lock return int renames System.VxWorks.Ext.Int_Lock; + function Int_Lock return int renames SVE.Int_Lock; -- If we are in the kernel space, lock interrupts. It typically maps to -- intLock. - function Int_Unlock (Old : int) return int - renames System.VxWorks.Ext.Int_Unlock; + procedure Int_Unlock (Old : int) renames SVE.Int_Unlock; -- If we are in the kernel space, unlock interrupts. It typically maps to -- intUnlock. The parameter Old is only used on PowerPC where it contains -- the returned value from Int_Lock (the old MPSR). @@ -285,34 +288,28 @@ package System.OS_Interface is -- VxWorks specific API -- -------------------------- - subtype STATUS is int; - -- Equivalent of the C type STATUS - - OK : constant STATUS := 0; - ERROR : constant STATUS := Interfaces.C.int (-1); - function taskIdVerify (tid : t_id) return STATUS; pragma Import (C, taskIdVerify, "taskIdVerify"); function taskIdSelf return t_id; pragma Import (C, taskIdSelf, "taskIdSelf"); - function taskOptionsGet (tid : t_id; pOptions : access int) return int; + function taskOptionsGet (tid : t_id; pOptions : access int) return STATUS; pragma Import (C, taskOptionsGet, "taskOptionsGet"); - function taskSuspend (tid : t_id) return int; + function taskSuspend (tid : t_id) return STATUS; pragma Import (C, taskSuspend, "taskSuspend"); - function taskResume (tid : t_id) return int; + function taskResume (tid : t_id) return STATUS; pragma Import (C, taskResume, "taskResume"); - function taskIsSuspended (tid : t_id) return int; + function taskIsSuspended (tid : t_id) return BOOL; pragma Import (C, taskIsSuspended, "taskIsSuspended"); - function taskDelay (ticks : int) return int; + function taskDelay (ticks : int) return STATUS; pragma Import (C, taskDelay, "taskDelay"); - function sysClkRateGet return int; + function sysClkRateGet return vx_freq_t; pragma Import (C, sysClkRateGet, "sysClkRateGet"); -- VxWorks 5.x specific functions @@ -320,17 +317,17 @@ package System.OS_Interface is -- taskVarLib: eg VxWorks 6 RTPs function taskVarAdd - (tid : t_id; pVar : access System.Address) return int; + (tid : t_id; pVar : access System.Address) return STATUS; pragma Import (C, taskVarAdd, "taskVarAdd"); function taskVarDelete - (tid : t_id; pVar : access System.Address) return int; + (tid : t_id; pVar : access System.Address) return STATUS; pragma Import (C, taskVarDelete, "taskVarDelete"); function taskVarSet (tid : t_id; pVar : access System.Address; - value : System.Address) return int; + value : System.Address) return STATUS; pragma Import (C, taskVarSet, "taskVarSet"); function taskVarGet @@ -379,15 +376,15 @@ package System.OS_Interface is procedure taskDelete (tid : t_id); pragma Import (C, taskDelete, "taskDelete"); - function Set_Time_Slice (ticks : int) return int - renames System.VxWorks.Ext.Set_Time_Slice; + function Set_Time_Slice (ticks : int) return STATUS renames + SVE.Set_Time_Slice; -- Calls kernelTimeSlice under VxWorks 5.x, VxWorks 653, or in VxWorks 6 -- kernel apps. Returns ERROR for RTPs, VxWorks 5 /CERT - function taskPriorityGet (tid : t_id; pPriority : access int) return int; + function taskPriorityGet (tid : t_id; pPriority : access int) return STATUS; pragma Import (C, taskPriorityGet, "taskPriorityGet"); - function taskPrioritySet (tid : t_id; newPriority : int) return int; + function taskPrioritySet (tid : t_id; newPriority : int) return STATUS; pragma Import (C, taskPrioritySet, "taskPrioritySet"); -- Semaphore creation flags @@ -419,7 +416,7 @@ package System.OS_Interface is -- semTake() timeout with ticks > NO_WAIT S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; - subtype SEM_ID is System.VxWorks.Ext.SEM_ID; + subtype SEM_ID is SVE.SEM_ID; -- typedef struct semaphore *SEM_ID; -- We use two different kinds of VxWorks semaphores: mutex and binary @@ -433,14 +430,13 @@ package System.OS_Interface is function semMCreate (options : int) return SEM_ID; pragma Import (C, semMCreate, "semMCreate"); - function semDelete (Sem : SEM_ID) return int - renames System.VxWorks.Ext.semDelete; + function semDelete (Sem : SEM_ID) return STATUS renames SVE.semDelete; -- Delete a semaphore - function semGive (Sem : SEM_ID) return int; + function semGive (Sem : SEM_ID) return STATUS; pragma Import (C, semGive, "semGive"); - function semTake (Sem : SEM_ID; timeout : int) return int; + function semTake (Sem : SEM_ID; timeout : int) return STATUS; pragma Import (C, semTake, "semTake"); -- Attempt to take binary semaphore. Error is returned if operation -- times out @@ -458,16 +454,16 @@ package System.OS_Interface is function Binary_Semaphore_Create return Binary_Semaphore_Id; pragma Inline (Binary_Semaphore_Create); - function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return int; + function Binary_Semaphore_Delete (ID : Binary_Semaphore_Id) return STATUS; pragma Inline (Binary_Semaphore_Delete); - function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return int; + function Binary_Semaphore_Obtain (ID : Binary_Semaphore_Id) return STATUS; pragma Inline (Binary_Semaphore_Obtain); - function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return int; + function Binary_Semaphore_Release (ID : Binary_Semaphore_Id) return STATUS; pragma Inline (Binary_Semaphore_Release); - function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return int; + function Binary_Semaphore_Flush (ID : Binary_Semaphore_Id) return STATUS; pragma Inline (Binary_Semaphore_Flush); ------------------------------------------------------------ @@ -482,16 +478,16 @@ package System.OS_Interface is function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; - Parameter : System.Address := System.Null_Address) return int; + Parameter : System.Address := System.Null_Address) return STATUS; pragma Inline (Interrupt_Connect); -- Use this to set up an user handler. The routine installs a user handler -- which is invoked after the OS has saved enough context for a high-level -- language routine to be safely invoked. - function Interrupt_Context return int; + function Interrupt_Context return BOOL; pragma Inline (Interrupt_Context); - -- Return 1 if executing in an interrupt context; return 0 if executing in - -- a task context. + -- Return 1 (TRUE) if executing in an interrupt context; + -- return 0 (FALSE) if executing in a task context. function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Inline (Interrupt_Number_To_Vector); @@ -503,12 +499,12 @@ package System.OS_Interface is -------------------------------- function taskCpuAffinitySet (tid : t_id; CPU : int) return int - renames System.VxWorks.Ext.taskCpuAffinitySet; + renames SVE.taskCpuAffinitySet; -- For SMP run-times the affinity to CPU. -- For uniprocessor systems return ERROR status. function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int - renames System.VxWorks.Ext.taskMaskAffinitySet; + renames SVE.taskMaskAffinitySet; -- For SMP run-times the affinity to CPU_Set. -- For uniprocessor systems return ERROR status. @@ -524,5 +520,5 @@ private ERROR_PID : constant pid_t := -1; - type sigset_t is new System.VxWorks.Ext.sigset_t; + type sigset_t is new SVE.sigset_t; end System.OS_Interface; diff --git a/gcc/ada/libgnarl/s-taprop__vxworks.adb b/gcc/ada/libgnarl/s-taprop__vxworks.adb index a87d1a0..273aca8 100644 --- a/gcc/ada/libgnarl/s-taprop__vxworks.adb +++ b/gcc/ada/libgnarl/s-taprop__vxworks.adb @@ -62,12 +62,17 @@ package body System.Task_Primitives.Operations is use System.Tasking; use System.OS_Interface; use System.Parameters; - use type System.VxWorks.Ext.t_id; use type Interfaces.C.int; use type System.OS_Interface.unsigned; + use type System.VxWorks.Ext.t_id; + use type System.VxWorks.Ext.STATUS; + use type System.VxWorks.Ext.BOOL; - subtype int is System.OS_Interface.int; + subtype int is System.OS_Interface.int; subtype unsigned is System.OS_Interface.unsigned; + subtype STATUS is System.VxWorks.Ext.STATUS; + + OK : constant STATUS := System.VxWorks.Ext.OK; Relative : constant := 0; @@ -333,17 +338,17 @@ package body System.Task_Primitives.Operations is ------------------- procedure Finalize_Lock (L : not null access Lock) is - Result : int; + Result : STATUS; begin Result := semDelete (L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Finalize_Lock; procedure Finalize_Lock (L : not null access RTS_Lock) is - Result : int; + Result : STATUS; begin Result := semDelete (L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Finalize_Lock; ---------------- @@ -354,7 +359,7 @@ package body System.Task_Primitives.Operations is (L : not null access Lock; Ceiling_Violation : out Boolean) is - Result : int; + Result : STATUS; begin if L.Protocol = Prio_Protect @@ -367,21 +372,21 @@ package body System.Task_Primitives.Operations is end if; Result := semTake (L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Write_Lock; procedure Write_Lock (L : not null access RTS_Lock) is - Result : int; + Result : STATUS; begin Result := semTake (L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Write_Lock; procedure Write_Lock (T : Task_Id) is - Result : int; + Result : STATUS; begin Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Write_Lock; --------------- @@ -400,24 +405,24 @@ package body System.Task_Primitives.Operations is ------------ procedure Unlock (L : not null access Lock) is - Result : int; + Result : STATUS; begin Result := semGive (L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Unlock; procedure Unlock (L : not null access RTS_Lock) is - Result : int; + Result : STATUS; begin Result := semGive (L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Unlock; procedure Unlock (T : Task_Id) is - Result : int; + Result : STATUS; begin Result := semGive (T.Common.LL.L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Unlock; ----------------- @@ -442,7 +447,7 @@ package body System.Task_Primitives.Operations is procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : int; + Result : STATUS; begin pragma Assert (Self_ID = Self); @@ -450,7 +455,7 @@ package body System.Task_Primitives.Operations is -- Release the mutex before sleeping Result := semGive (Self_ID.Common.LL.L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); -- Perform a blocking operation to take the CV semaphore. Note that a -- blocking operation in VxWorks will reenable task scheduling. When we @@ -458,12 +463,12 @@ package body System.Task_Primitives.Operations is -- again be disabled. Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); -- Take the mutex back Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Sleep; ----------------- @@ -486,7 +491,7 @@ package body System.Task_Primitives.Operations is Orig : constant Duration := Monotonic_Clock; Absolute : Duration; Ticks : int; - Result : int; + Result : STATUS; Wakeup : Boolean := False; begin @@ -516,7 +521,7 @@ package body System.Task_Primitives.Operations is -- Release the mutex before sleeping Result := semGive (Self_ID.Common.LL.L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); -- Perform a blocking operation to take the CV semaphore. Note -- that a blocking operation in VxWorks will reenable task @@ -525,7 +530,7 @@ package body System.Task_Primitives.Operations is Result := semTake (Self_ID.Common.LL.CV, Ticks); - if Result = 0 then + if Result = OK then -- Somebody may have called Wakeup for us @@ -556,7 +561,7 @@ package body System.Task_Primitives.Operations is -- Take the mutex back Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); exit when Timedout or Wakeup; end loop; @@ -590,7 +595,7 @@ package body System.Task_Primitives.Operations is Timedout : Boolean; Aborted : Boolean := False; - Result : int; + Result : STATUS; pragma Warnings (Off, Result); begin @@ -617,7 +622,7 @@ package body System.Task_Primitives.Operations is Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); Self_ID.Common.State := Delay_Sleep; Timedout := False; @@ -628,13 +633,13 @@ package body System.Task_Primitives.Operations is -- Release the TCB before sleeping Result := semGive (Self_ID.Common.LL.L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); exit when Aborted; Result := semTake (Self_ID.Common.LL.CV, Ticks); - if Result /= 0 then + if Result /= OK then -- If Ticks = int'last, it was most probably truncated, so make -- another round after recomputing Ticks from absolute time. @@ -655,7 +660,7 @@ package body System.Task_Primitives.Operations is Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); + pragma Assert (Result = OK); exit when Timedout; end loop; @@ -697,10 +702,10 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : int; + Result : STATUS; begin Result := semGive (T.Common.LL.CV); - pragma Assert (Result = 0); + pragma Assert (Result = OK); end Wakeup; ----------- @@ -709,7 +714,7 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is pragma Unreferenced (Do_Yield); - Result : int; + Result : STATUS; pragma Unreferenced (Result); begin Result := taskDelay (0); @@ -726,13 +731,13 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Loss_Of_Inheritance); - Result : int; + Result : STATUS; begin Result := taskPrioritySet (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); - pragma Assert (Result = 0); + pragma Assert (Result = OK); -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of -- the priority queue instead of the head. This is not the behavior @@ -938,16 +943,16 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : int; + Result : STATUS; begin Result := semDelete (T.Common.LL.L.Mutex); - pragma Assert (Result = 0); + pragma Assert (Result = OK); T.Common.LL.Thread := Null_Thread_Id; Result := semDelete (T.Common.LL.CV); - pragma Assert (Result = 0); + pragma Assert (Result = OK); if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; @@ -1137,7 +1142,7 @@ package body System.Task_Primitives.Operations is S.State := False; Result := semGive (S.L); - pragma Assert (Result = 0); + pragma Assert (Result = OK); SSL.Abort_Undefer.all; @@ -1218,7 +1223,7 @@ package body System.Task_Primitives.Operations is if T.Common.LL.Thread /= Null_Thread_Id and then T.Common.LL.Thread /= Thread_Self then - return taskSuspend (T.Common.LL.Thread) = 0; + return taskSuspend (T.Common.LL.Thread) = OK; else return True; end if; @@ -1236,7 +1241,7 @@ package body System.Task_Primitives.Operations is if T.Common.LL.Thread /= Null_Thread_Id and then T.Common.LL.Thread /= Thread_Self then - return taskResume (T.Common.LL.Thread) = 0; + return taskResume (T.Common.LL.Thread) = OK; else return True; end if; @@ -1251,7 +1256,7 @@ package body System.Task_Primitives.Operations is Thread_Self : constant Thread_Id := taskIdSelf; C : Task_Id; - Dummy : int; + Dummy : STATUS; Old : int; begin @@ -1268,7 +1273,7 @@ package body System.Task_Primitives.Operations is C := C.Common.All_Tasks_Link; end loop; - Dummy := Int_Unlock (Old); + Int_Unlock (Old); end Stop_All_Tasks; --------------- @@ -1278,7 +1283,7 @@ package body System.Task_Primitives.Operations is function Stop_Task (T : ST.Task_Id) return Boolean is begin if T.Common.LL.Thread /= Null_Thread_Id then - return Task_Stop (T.Common.LL.Thread) = 0; + return Task_Stop (T.Common.LL.Thread) = OK; else return True; end if; @@ -1292,7 +1297,7 @@ package body System.Task_Primitives.Operations is is begin if T.Common.LL.Thread /= Null_Thread_Id then - return Task_Cont (T.Common.LL.Thread) = 0; + return Task_Cont (T.Common.LL.Thread) = OK; else return True; end if; @@ -1304,7 +1309,7 @@ package body System.Task_Primitives.Operations is function Is_Task_Context return Boolean is begin - return System.OS_Interface.Interrupt_Context /= 1; + return OSI.Interrupt_Context = 0; end Is_Task_Context; ---------------- @@ -1312,7 +1317,7 @@ package body System.Task_Primitives.Operations is ---------------- procedure Initialize (Environment_Task : Task_Id) is - Result : int; + Result : STATUS; pragma Unreferenced (Result); begin diff --git a/gcc/ada/libgnarl/s-taskin.ads b/gcc/ada/libgnarl/s-taskin.ads index 5c03829..cf560b5 100644 --- a/gcc/ada/libgnarl/s-taskin.ads +++ b/gcc/ada/libgnarl/s-taskin.ads @@ -368,14 +368,6 @@ package System.Tasking is -- Used to represent protected procedures to be executed when task -- terminates. - type Initialization_Handler is access procedure; - pragma Favor_Top_Level (Initialization_Handler); - -- Use to represent procedures to be executed at task initialization. - - Global_Initialization_Handler : Initialization_Handler := null; - pragma Atomic (Global_Initialization_Handler); - -- Global handler called when each task initializes. - ------------------------------------ -- Dispatching domain definitions -- ------------------------------------ diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb index 88850c2..bbc7d14 100644 --- a/gcc/ada/libgnarl/s-tassta.adb +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -35,6 +35,7 @@ pragma Partition_Elaboration_Policy (Concurrent); with Ada.Exceptions; with Ada.Unchecked_Deallocation; +with Ada.Task_Initialization; with System.Interrupt_Management; with System.Tasking.Debug; @@ -1177,6 +1178,14 @@ package body System.Tasking.Stages is Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID); end if; + declare + use Ada.Task_Initialization; + + Global_Initialization_Handler : Initialization_Handler; + pragma Atomic (Global_Initialization_Handler); + pragma Import (Ada, Global_Initialization_Handler, + "__gnat_global_initialization_handler"); + begin -- We are separating the following portion of the code in order to -- place the exception handlers in a different block. In this way, diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb index e5d4089..1343f6b 100644 --- a/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb +++ b/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb @@ -35,6 +35,8 @@ separate (System.Task_Primitives.Operations) package body Specific is + ERROR : constant STATUS := System.VxWorks.Ext.ERROR; + ATCB_Key : int := 0; -- Key used to find the Ada Task_Id associated with a thread @@ -43,9 +45,10 @@ package body Specific is ---------------- procedure Initialize is + IERR : constant := -1; begin ATCB_Key := tlsKeyCreate; - pragma Assert (ATCB_Key /= ERROR); + pragma Assert (ATCB_Key /= IERR); end Initialize; ------------------- diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb index 2d7cf00..9dc5d8b 100644 --- a/gcc/ada/libgnarl/s-tpopsp__vxworks.adb +++ b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb @@ -35,6 +35,8 @@ separate (System.Task_Primitives.Operations) package body Specific is + ERROR : constant STATUS := System.VxWorks.Ext.ERROR; + ATCB_Key : aliased System.Address := System.Null_Address; -- Key used to find the Ada Task_Id associated with a thread @@ -70,8 +72,9 @@ package body Specific is ------------------- function Is_Valid_Task return Boolean is + IERR : constant := -1; begin - return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR; + return taskVarGet (taskIdSelf, ATCB_Key'Access) /= IERR; end Is_Valid_Task; --------- diff --git a/gcc/ada/libgnarl/s-vxwext.adb b/gcc/ada/libgnarl/s-vxwext.adb index 0e1a792..d50d93d 100644 --- a/gcc/ada/libgnarl/s-vxwext.adb +++ b/gcc/ada/libgnarl/s-vxwext.adb @@ -30,7 +30,7 @@ package body System.VxWorks.Ext is - ERROR : constant := -1; + IERR : constant := -1; ------------------------ -- taskCpuAffinitySet -- @@ -39,7 +39,7 @@ package body System.VxWorks.Ext is function taskCpuAffinitySet (tid : t_id; CPU : int) return int is pragma Unreferenced (tid, CPU); begin - return ERROR; + return IERR; end taskCpuAffinitySet; ------------------------- @@ -49,7 +49,7 @@ package body System.VxWorks.Ext is function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is pragma Unreferenced (tid, CPU_Set); begin - return ERROR; + return IERR; end taskMaskAffinitySet; end System.VxWorks.Ext; diff --git a/gcc/ada/libgnarl/s-vxwext.ads b/gcc/ada/libgnarl/s-vxwext.ads index 915db33..ab73415 100644 --- a/gcc/ada/libgnarl/s-vxwext.ads +++ b/gcc/ada/libgnarl/s-vxwext.ads @@ -46,6 +46,18 @@ package System.VxWorks.Ext is subtype int is Interfaces.C.int; subtype unsigned is Interfaces.C.unsigned; + type STATUS is new int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := -1; + + type BOOL is new int; + -- Equivalent of the C type BOOL + + type vx_freq_t is new unsigned; + -- Equivalent of the C type _Vx_freq_t + type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -54,7 +66,7 @@ package System.VxWorks.Ext is function Int_Lock return int; pragma Import (C, Int_Lock, "intLock"); - function Int_Unlock (Old : int) return int; + procedure Int_Unlock (Old : int); pragma Import (C, Int_Unlock, "intUnlock"); function Interrupt_Connect @@ -63,7 +75,7 @@ package System.VxWorks.Ext is Parameter : System.Address := System.Null_Address) return int; pragma Import (C, Interrupt_Connect, "intConnect"); - function Interrupt_Context return int; + function Interrupt_Context return BOOL; pragma Import (C, Interrupt_Context, "intContext"); function Interrupt_Number_To_Vector diff --git a/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb b/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb index ea1f71c..b78e078 100644 --- a/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb +++ b/gcc/ada/libgnarl/s-vxwext__kernel-smp.adb @@ -33,7 +33,7 @@ package body System.VxWorks.Ext is - ERROR : constant := -1; + IERR : constant := -1; -------------- -- Int_Lock -- @@ -41,25 +41,25 @@ package body System.VxWorks.Ext is function Int_Lock return int is begin - return ERROR; + return IERR; end Int_Lock; ---------------- -- Int_Unlock -- ---------------- - function Int_Unlock (Old : int) return int is + procedure Int_Unlock (Old : int) is pragma Unreferenced (Old); begin - return ERROR; + null; end Int_Unlock; --------------- -- semDelete -- --------------- - function semDelete (Sem : SEM_ID) return int is - function Os_Sem_Delete (Sem : SEM_ID) return int; + function semDelete (Sem : SEM_ID) return STATUS is + function Os_Sem_Delete (Sem : SEM_ID) return STATUS; pragma Import (C, Os_Sem_Delete, "semDelete"); begin return Os_Sem_Delete (Sem); @@ -92,8 +92,8 @@ package body System.VxWorks.Ext is -- Task_Cont -- --------------- - function Task_Cont (tid : t_id) return int is - function taskCont (tid : t_id) return int; + function Task_Cont (tid : t_id) return STATUS is + function taskCont (tid : t_id) return STATUS; pragma Import (C, taskCont, "taskCont"); begin return taskCont (tid); @@ -103,8 +103,8 @@ package body System.VxWorks.Ext is -- Task_Stop -- --------------- - function Task_Stop (tid : t_id) return int is - function taskStop (tid : t_id) return int; + function Task_Stop (tid : t_id) return STATUS is + function taskStop (tid : t_id) return STATUS; pragma Import (C, taskStop, "taskStop"); begin return taskStop (tid); diff --git a/gcc/ada/libgnarl/s-vxwext__kernel.adb b/gcc/ada/libgnarl/s-vxwext__kernel.adb index 4743540..2f00059 100644 --- a/gcc/ada/libgnarl/s-vxwext__kernel.adb +++ b/gcc/ada/libgnarl/s-vxwext__kernel.adb @@ -34,7 +34,7 @@ package body System.VxWorks.Ext is - ERROR : constant := -1; + IERR : constant := -1; -------------- -- Int_Lock -- @@ -49,17 +49,17 @@ package body System.VxWorks.Ext is -- Int_Unlock -- ---------------- - function intUnlock (Old : int) return int; + procedure intUnlock (Old : int); pragma Import (C, intUnlock, "intUnlock"); - function Int_Unlock (Old : int) return int renames intUnlock; + procedure Int_Unlock (Old : int) renames intUnlock; --------------- -- semDelete -- --------------- - function semDelete (Sem : SEM_ID) return int is - function Os_Sem_Delete (Sem : SEM_ID) return int; + function semDelete (Sem : SEM_ID) return STATUS is + function Os_Sem_Delete (Sem : SEM_ID) return STATUS; pragma Import (C, Os_Sem_Delete, "semDelete"); begin return Os_Sem_Delete (Sem); @@ -72,7 +72,7 @@ package body System.VxWorks.Ext is function taskCpuAffinitySet (tid : t_id; CPU : int) return int is pragma Unreferenced (tid, CPU); begin - return ERROR; + return IERR; end taskCpuAffinitySet; ------------------------- @@ -82,15 +82,15 @@ package body System.VxWorks.Ext is function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is pragma Unreferenced (tid, CPU_Set); begin - return ERROR; + return IERR; end taskMaskAffinitySet; --------------- -- Task_Cont -- --------------- - function Task_Cont (tid : t_id) return int is - function taskCont (tid : t_id) return int; + function Task_Cont (tid : t_id) return STATUS is + function taskCont (tid : t_id) return STATUS; pragma Import (C, taskCont, "taskCont"); begin return taskCont (tid); @@ -100,8 +100,8 @@ package body System.VxWorks.Ext is -- Task_Stop -- --------------- - function Task_Stop (tid : t_id) return int is - function taskStop (tid : t_id) return int; + function Task_Stop (tid : t_id) return STATUS is + function taskStop (tid : t_id) return STATUS; pragma Import (C, taskStop, "taskStop"); begin return taskStop (tid); diff --git a/gcc/ada/libgnarl/s-vxwext__kernel.ads b/gcc/ada/libgnarl/s-vxwext__kernel.ads index 3c200a1..7b299b9 100644 --- a/gcc/ada/libgnarl/s-vxwext__kernel.ads +++ b/gcc/ada/libgnarl/s-vxwext__kernel.ads @@ -45,6 +45,18 @@ package System.VxWorks.Ext is subtype int is Interfaces.C.int; subtype unsigned is Interfaces.C.unsigned; + type STATUS is new int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := -1; + + type BOOL is new int; + -- Equivalent of the C type BOOL + + type vx_freq_t is new unsigned; + -- Equivalent of the C type _Vx_freq_t + type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -53,29 +65,29 @@ package System.VxWorks.Ext is function Int_Lock return int; pragma Convention (C, Int_Lock); - function Int_Unlock (Old : int) return int; + procedure Int_Unlock (Old : int); pragma Convention (C, Int_Unlock); function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; - Parameter : System.Address := System.Null_Address) return int; + Parameter : System.Address := System.Null_Address) return STATUS; pragma Import (C, Interrupt_Connect, "intConnect"); - function Interrupt_Context return int; + function Interrupt_Context return BOOL; pragma Import (C, Interrupt_Context, "intContext"); function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Import (C, Interrupt_Number_To_Vector, "__gnat_inum_to_ivec"); - function semDelete (Sem : SEM_ID) return int; + function semDelete (Sem : SEM_ID) return STATUS; pragma Convention (C, semDelete); - function Task_Cont (tid : t_id) return int; + function Task_Cont (tid : t_id) return STATUS; pragma Convention (C, Task_Cont); - function Task_Stop (tid : t_id) return int; + function Task_Stop (tid : t_id) return STATUS; pragma Convention (C, Task_Stop); function kill (pid : t_id; sig : int) return int; @@ -84,7 +96,7 @@ package System.VxWorks.Ext is function getpid return t_id; pragma Import (C, getpid, "taskIdSelf"); - function Set_Time_Slice (ticks : int) return int; + function Set_Time_Slice (ticks : int) return STATUS; pragma Import (C, Set_Time_Slice, "kernelTimeSlice"); type UINT64 is mod 2 ** Long_Long_Integer'Size; diff --git a/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb b/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb index 241a8f5..5bf6ae5 100644 --- a/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb +++ b/gcc/ada/libgnarl/s-vxwext__rtp-smp.adb @@ -33,7 +33,7 @@ package body System.VxWorks.Ext is - ERROR : constant := -1; + IERR : constant := -1; -------------- -- Int_Lock -- @@ -41,17 +41,17 @@ package body System.VxWorks.Ext is function Int_Lock return int is begin - return ERROR; + return IERR; end Int_Lock; ---------------- -- Int_Unlock -- ---------------- - function Int_Unlock (Old : int) return int is + procedure Int_Unlock (Old : int) is pragma Unreferenced (Old); begin - return ERROR; + null; end Int_Unlock; ----------------------- @@ -61,7 +61,7 @@ package body System.VxWorks.Ext is function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; - Parameter : System.Address := System.Null_Address) return int + Parameter : System.Address := System.Null_Address) return STATUS is pragma Unreferenced (Vector, Handler, Parameter); begin @@ -72,7 +72,7 @@ package body System.VxWorks.Ext is -- Interrupt_Context -- ----------------------- - function Interrupt_Context return int is + function Interrupt_Context return BOOL is begin -- For RTPs, never in an interrupt context @@ -95,8 +95,8 @@ package body System.VxWorks.Ext is -- semDelete -- --------------- - function semDelete (Sem : SEM_ID) return int is - function OS_semDelete (Sem : SEM_ID) return int; + function semDelete (Sem : SEM_ID) return STATUS is + function OS_semDelete (Sem : SEM_ID) return STATUS; pragma Import (C, OS_semDelete, "semDelete"); begin return OS_semDelete (Sem); @@ -106,7 +106,7 @@ package body System.VxWorks.Ext is -- Set_Time_Slice -- -------------------- - function Set_Time_Slice (ticks : int) return int is + function Set_Time_Slice (ticks : int) return STATUS is pragma Unreferenced (ticks); begin return ERROR; diff --git a/gcc/ada/libgnarl/s-vxwext__rtp.adb b/gcc/ada/libgnarl/s-vxwext__rtp.adb index f188ff8..543f152 100644 --- a/gcc/ada/libgnarl/s-vxwext__rtp.adb +++ b/gcc/ada/libgnarl/s-vxwext__rtp.adb @@ -33,7 +33,7 @@ package body System.VxWorks.Ext is - ERROR : constant := -1; + IERR : constant := -1; -------------- -- Int_Lock -- @@ -41,17 +41,17 @@ package body System.VxWorks.Ext is function Int_Lock return int is begin - return ERROR; + return IERR; end Int_Lock; ---------------- -- Int_Unlock -- ---------------- - function Int_Unlock (Old : int) return int is + procedure Int_Unlock (Old : int) is pragma Unreferenced (Old); begin - return ERROR; + null; end Int_Unlock; ----------------------- @@ -61,7 +61,7 @@ package body System.VxWorks.Ext is function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; - Parameter : System.Address := System.Null_Address) return int + Parameter : System.Address := System.Null_Address) return STATUS is pragma Unreferenced (Vector, Handler, Parameter); begin @@ -72,7 +72,7 @@ package body System.VxWorks.Ext is -- Interrupt_Context -- ----------------------- - function Interrupt_Context return int is + function Interrupt_Context return BOOL is begin -- For RTPs, never in an interrupt context @@ -95,8 +95,8 @@ package body System.VxWorks.Ext is -- semDelete -- --------------- - function semDelete (Sem : SEM_ID) return int is - function OS_semDelete (Sem : SEM_ID) return int; + function semDelete (Sem : SEM_ID) return STATUS is + function OS_semDelete (Sem : SEM_ID) return STATUS; pragma Import (C, OS_semDelete, "semDelete"); begin return OS_semDelete (Sem); @@ -106,7 +106,7 @@ package body System.VxWorks.Ext is -- Set_Time_Slice -- -------------------- - function Set_Time_Slice (ticks : int) return int is + function Set_Time_Slice (ticks : int) return STATUS is pragma Unreferenced (ticks); begin return ERROR; @@ -119,7 +119,7 @@ package body System.VxWorks.Ext is function taskCpuAffinitySet (tid : t_id; CPU : int) return int is pragma Unreferenced (tid, CPU); begin - return ERROR; + return IERR; end taskCpuAffinitySet; ------------------------- @@ -129,7 +129,7 @@ package body System.VxWorks.Ext is function taskMaskAffinitySet (tid : t_id; CPU_Set : unsigned) return int is pragma Unreferenced (tid, CPU_Set); begin - return ERROR; + return IERR; end taskMaskAffinitySet; end System.VxWorks.Ext; diff --git a/gcc/ada/libgnarl/s-vxwext__rtp.ads b/gcc/ada/libgnarl/s-vxwext__rtp.ads index d13344e..995d098 100644 --- a/gcc/ada/libgnarl/s-vxwext__rtp.ads +++ b/gcc/ada/libgnarl/s-vxwext__rtp.ads @@ -45,6 +45,18 @@ package System.VxWorks.Ext is subtype int is Interfaces.C.int; subtype unsigned is Interfaces.C.unsigned; + type STATUS is new int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := -1; + + type BOOL is new int; + -- Equivalent of the C type BOOL + + type vx_freq_t is new unsigned; + -- Equivalent of the C type _Vx_freq_t + type Interrupt_Handler is access procedure (parameter : System.Address); pragma Convention (C, Interrupt_Handler); @@ -53,29 +65,29 @@ package System.VxWorks.Ext is function Int_Lock return int; pragma Inline (Int_Lock); - function Int_Unlock (Old : int) return int; + procedure Int_Unlock (Old : int); pragma Inline (Int_Unlock); function Interrupt_Connect (Vector : Interrupt_Vector; Handler : Interrupt_Handler; - Parameter : System.Address := System.Null_Address) return int; + Parameter : System.Address := System.Null_Address) return STATUS; pragma Convention (C, Interrupt_Connect); - function Interrupt_Context return int; + function Interrupt_Context return BOOL; pragma Convention (C, Interrupt_Context); function Interrupt_Number_To_Vector (intNum : int) return Interrupt_Vector; pragma Convention (C, Interrupt_Number_To_Vector); - function semDelete (Sem : SEM_ID) return int; + function semDelete (Sem : SEM_ID) return STATUS; pragma Convention (C, semDelete); - function Task_Cont (tid : t_id) return int; + function Task_Cont (tid : t_id) return STATUS; pragma Import (C, Task_Cont, "taskResume"); - function Task_Stop (tid : t_id) return int; + function Task_Stop (tid : t_id) return STATUS; pragma Import (C, Task_Stop, "taskSuspend"); function kill (pid : t_id; sig : int) return int; @@ -84,7 +96,7 @@ package System.VxWorks.Ext is function getpid return t_id; pragma Import (C, getpid, "getpid"); - function Set_Time_Slice (ticks : int) return int; + function Set_Time_Slice (ticks : int) return STATUS; pragma Inline (Set_Time_Slice); -------------------------------- diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads index ab55086..f4086ea 100644 --- a/gcc/ada/libgnat/a-cbdlli.ads +++ b/gcc/ada/libgnat/a-cbdlli.ads @@ -57,11 +57,11 @@ is Default_Iterator => Iterate, Iterator_Element => Element_Type, Aggregate => (Empty => Empty, - Add_Unnamed => Append); - pragma Preelaborable_Initialization (List); + Add_Unnamed => Append), + Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization; - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); + type Cursor is private with Preelaborable_Initialization; Empty_List : constant List; diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads index 8be64c8..cdd4135 100644 --- a/gcc/ada/libgnat/a-cbhama.ads +++ b/gcc/ada/libgnat/a-cbhama.ads @@ -59,12 +59,13 @@ is Default_Iterator => Iterate, Iterator_Element => Element_Type, Aggregate => (Empty => Empty, - Add_Named => Insert); + Add_Named => Insert), + Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization + and + Key_Type'Preelaborable_Initialization; - pragma Preelaborable_Initialization (Map); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); + type Cursor is private with Preelaborable_Initialization; Empty_Map : constant Map; -- Map objects declared without an initialization expression are diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads index 92926c1..78b31cf 100644 --- a/gcc/ada/libgnat/a-cbhase.ads +++ b/gcc/ada/libgnat/a-cbhase.ads @@ -61,12 +61,11 @@ is Default_Iterator => Iterate, Iterator_Element => Element_Type, Aggregate => (Empty => Empty, - Add_Unnamed => Include); + Add_Unnamed => Include), + Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization; - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); + type Cursor is private with Preelaborable_Initialization; Empty_Set : constant Set; -- Set objects declared without an initialization expression are diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads index c7e221a..3712039 100644 --- a/gcc/ada/libgnat/a-cbmutr.ads +++ b/gcc/ada/libgnat/a-cbmutr.ads @@ -53,11 +53,11 @@ is with Constant_Indexing => Constant_Reference, Variable_Indexing => Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; - pragma Preelaborable_Initialization (Tree); + Iterator_Element => Element_Type, + Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization; - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); + type Cursor is private with Preelaborable_Initialization; Empty_Tree : constant Tree; diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads index f87522a..9d40a51 100644 --- a/gcc/ada/libgnat/a-cborma.ads +++ b/gcc/ada/libgnat/a-cborma.ads @@ -60,12 +60,13 @@ is Default_Iterator => Iterate, Iterator_Element => Element_Type, Aggregate => (Empty => Empty, - Add_Named => Insert); + Add_Named => Insert), + Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization + and + Key_Type'Preelaborable_Initialization; - pragma Preelaborable_Initialization (Map); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); + type Cursor is private with Preelaborable_Initialization; Empty_Map : constant Map; diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads index 06bd20f..31b8b91 100644 --- a/gcc/ada/libgnat/a-cborse.ads +++ b/gcc/ada/libgnat/a-cborse.ads @@ -59,12 +59,11 @@ is Default_Iterator => Iterate, Iterator_Element => Element_Type, Aggregate => (Empty => Empty, - Add_Unnamed => Include); + Add_Unnamed => Include), + Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization; - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); + type Cursor is private with Preelaborable_Initialization; Empty_Set : constant Set; diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index 590643e..ded496b 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -44,6 +44,7 @@ is pragma Assertion_Policy (Pre => Ignore); pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); type List (Capacity : Count_Type) is private with diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads index 2b49c13..59e295d 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -69,6 +69,7 @@ is pragma Assertion_Policy (Pre => Ignore); pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads index 9bcd8ce..23b3b6d 100644 --- a/gcc/ada/libgnat/a-cfhase.ads +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -67,6 +67,7 @@ is pragma Assertion_Policy (Pre => Ignore); pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads index 9b95437..bd0c334 100644 --- a/gcc/ada/libgnat/a-cfinve.ads +++ b/gcc/ada/libgnat/a-cfinve.ads @@ -60,6 +60,7 @@ is pragma Assertion_Policy (Pre => Ignore); pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); subtype Extended_Index is Index_Type'Base diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads index a1cad03..048e7cb 100644 --- a/gcc/ada/libgnat/a-cforma.ads +++ b/gcc/ada/libgnat/a-cforma.ads @@ -68,6 +68,7 @@ is pragma Assertion_Policy (Pre => Ignore); pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); function Equivalent_Keys (Left, Right : Key_Type) return Boolean with diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads index e1d7c91..db7c586 100644 --- a/gcc/ada/libgnat/a-cforse.ads +++ b/gcc/ada/libgnat/a-cforse.ads @@ -64,6 +64,7 @@ is pragma Assertion_Policy (Pre => Ignore); pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); function Equivalent_Elements (Left, Right : Element_Type) return Boolean diff --git a/gcc/ada/libgnat/a-chahan.adb b/gcc/ada/libgnat/a-chahan.adb index 827794c..411d485 100644 --- a/gcc/ada/libgnat/a-chahan.adb +++ b/gcc/ada/libgnat/a-chahan.adb @@ -29,11 +29,19 @@ -- -- ------------------------------------------------------------------------------ +-- Loop invariants in this unit are meant for analysis only, not for run-time +-- checking, as it would be too costly otherwise. This is enforced by setting +-- the assertion policy to Ignore. + +pragma Assertion_Policy (Loop_Invariant => Ignore); + with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; -package body Ada.Characters.Handling is +package body Ada.Characters.Handling + with SPARK_Mode +is ------------------------------------ -- Character Classification Table -- @@ -299,9 +307,7 @@ package body Ada.Characters.Handling is ------------------ function Is_Character (Item : Wide_Character) return Boolean is - begin - return Wide_Character'Pos (Item) < 256; - end Is_Character; + (Wide_Character'Pos (Item) < 256); ---------------- -- Is_Control -- @@ -344,9 +350,7 @@ package body Ada.Characters.Handling is ---------------- function Is_ISO_646 (Item : Character) return Boolean is - begin - return Item in ISO_646; - end Is_ISO_646; + (Item in ISO_646); -- Note: much more efficient coding of the following function is possible -- by testing several 16#80# bits in a complete word in a single operation @@ -357,6 +361,8 @@ package body Ada.Characters.Handling is if Item (J) not in ISO_646 then return False; end if; + pragma Loop_Invariant + (for all K in Item'First .. J => Is_ISO_646 (Item (K))); end loop; return True; @@ -456,6 +462,8 @@ package body Ada.Characters.Handling is if Wide_Character'Pos (Item (J)) >= 256 then return False; end if; + pragma Loop_Invariant + (for all K in Item'First .. J => Is_Character (Item (K))); end loop; return True; @@ -475,15 +483,18 @@ package body Ada.Characters.Handling is -------------- function To_Basic (Item : Character) return Character is - begin - return Value (Basic_Map, Item); - end To_Basic; + (Value (Basic_Map, Item)); function To_Basic (Item : String) return String is begin - return Result : String (1 .. Item'Length) do + return Result : String (1 .. Item'Length) with Relaxed_Initialization do for J in Item'Range loop Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); + pragma Loop_Invariant + (Result (1 .. J - Item'First + 1)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + Result (K - (Item'First - 1)) = To_Basic (Item (K))); end loop; end return; end To_Basic; @@ -511,24 +522,25 @@ package body Ada.Characters.Handling is function To_ISO_646 (Item : Character; Substitute : ISO_646 := ' ') return ISO_646 - is - begin - return (if Item in ISO_646 then Item else Substitute); - end To_ISO_646; + is (if Item in ISO_646 then Item else Substitute); function To_ISO_646 (Item : String; Substitute : ISO_646 := ' ') return String is - Result : String (1 .. Item'Length); - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := - (if Item (J) in ISO_646 then Item (J) else Substitute); - end loop; - - return Result; + return Result : String (1 .. Item'Length) with Relaxed_Initialization do + for J in Item'Range loop + Result (J - (Item'First - 1)) := + (if Item (J) in ISO_646 then Item (J) else Substitute); + pragma Loop_Invariant + (Result (1 .. J - Item'First + 1)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + Result (K - (Item'First - 1)) = + To_ISO_646 (Item (K), Substitute)); + end loop; + end return; end To_ISO_646; -------------- @@ -536,15 +548,18 @@ package body Ada.Characters.Handling is -------------- function To_Lower (Item : Character) return Character is - begin - return Value (Lower_Case_Map, Item); - end To_Lower; + (Value (Lower_Case_Map, Item)); function To_Lower (Item : String) return String is begin - return Result : String (1 .. Item'Length) do + return Result : String (1 .. Item'Length) with Relaxed_Initialization do for J in Item'Range loop Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); + pragma Loop_Invariant + (Result (1 .. J - Item'First + 1)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + Result (K - (Item'First - 1)) = To_Lower (Item (K))); end loop; end return; end To_Lower; @@ -557,34 +572,40 @@ package body Ada.Characters.Handling is (Item : Wide_String; Substitute : Character := ' ') return String is - Result : String (1 .. Item'Length); - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); - end loop; - - return Result; + return Result : String (1 .. Item'Length) with Relaxed_Initialization do + for J in Item'Range loop + Result (J - (Item'First - 1)) := + To_Character (Item (J), Substitute); + pragma Loop_Invariant + (Result (1 .. J - (Item'First - 1))'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + Result (K - (Item'First - 1)) = + To_Character (Item (K), Substitute)); + end loop; + end return; end To_String; -------------- -- To_Upper -- -------------- - function To_Upper - (Item : Character) return Character - is - begin - return Value (Upper_Case_Map, Item); - end To_Upper; + function To_Upper (Item : Character) return Character is + (Value (Upper_Case_Map, Item)); function To_Upper (Item : String) return String is begin - return Result : String (1 .. Item'Length) do + return Result : String (1 .. Item'Length) with Relaxed_Initialization do for J in Item'Range loop Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); + pragma Loop_Invariant + (Result (1 .. J - Item'First + 1)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + Result (K - (Item'First - 1)) = To_Upper (Item (K))); end loop; end return; end To_Upper; @@ -607,14 +628,19 @@ package body Ada.Characters.Handling is function To_Wide_String (Item : String) return Wide_String is - Result : Wide_String (1 .. Item'Length); - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Wide_Character (Item (J)); - end loop; - - return Result; + return Result : Wide_String (1 .. Item'Length) + with Relaxed_Initialization + do + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Wide_Character (Item (J)); + pragma Loop_Invariant + (Result (1 .. J - (Item'First - 1))'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + Result (K - (Item'First - 1)) = To_Wide_Character (Item (K))); + end loop; + end return; end To_Wide_String; end Ada.Characters.Handling; diff --git a/gcc/ada/libgnat/a-chahan.ads b/gcc/ada/libgnat/a-chahan.ads index 2f93e7c..093237d 100644 --- a/gcc/ada/libgnat/a-chahan.ads +++ b/gcc/ada/libgnat/a-chahan.ads @@ -33,7 +33,16 @@ -- -- ------------------------------------------------------------------------------ -package Ada.Characters.Handling is +-- Postconditions in this unit are meant for analysis only, not for run-time +-- checking, in order not to slow down the execution of these functions. + +pragma Assertion_Policy (Post => Ignore); + +with Ada.Characters.Latin_1; + +package Ada.Characters.Handling + with SPARK_Mode +is pragma Pure; -- In accordance with Ada 2005 AI-362 @@ -41,54 +50,296 @@ package Ada.Characters.Handling is -- Character Classification Functions -- ---------------------------------------- - function Is_Control (Item : Character) return Boolean; - function Is_Graphic (Item : Character) return Boolean; - function Is_Letter (Item : Character) return Boolean; - function Is_Lower (Item : Character) return Boolean; - function Is_Upper (Item : Character) return Boolean; - function Is_Basic (Item : Character) return Boolean; - function Is_Digit (Item : Character) return Boolean; + -- In the description below for each function that returns a Boolean + -- result, the effect is described in terms of the conditions under which + -- the value True is returned. If these conditions are not met, then the + -- function returns False. + -- + -- Each of the following classification functions has a formal Character + -- parameter, Item, and returns a Boolean result. + + function Is_Control (Item : Character) return Boolean + with + Post => Is_Control'Result = + (Character'Pos (Item) in 0 .. 31 | 127 .. 159); + -- True if Item is a control character. A control character is a character + -- whose position is in one of the ranges 0..31 or 127..159. + + function Is_Graphic (Item : Character) return Boolean + with + Post => Is_Graphic'Result = + (Character'Pos (Item) in 32 .. 126 | 160 .. 255); + -- True if Item is a graphic character. A graphic character is a character + -- whose position is in one of the ranges 32..126 or 160..255. + + function Is_Letter (Item : Character) return Boolean + with + Post => Is_Letter'Result = + (Item in 'A' .. 'Z' | 'a' .. 'z' + or else Character'Pos (Item) in 192 .. 214 | 216 .. 246 | 248 .. 255); + -- True if Item is a letter. A letter is a character that is in one of the + -- ranges 'A'..'Z' or 'a'..'z', or whose position is in one of the ranges + -- 192..214, 216..246, or 248..255. + + function Is_Lower (Item : Character) return Boolean + with + Post => Is_Lower'Result = + (Item in 'a' .. 'z' + or else Character'Pos (Item) in 223 .. 246 | 248 .. 255); + -- True if Item is a lower-case letter. A lower-case letter is a character + -- that is in the range 'a'..'z', or whose position is in one of the ranges + -- 223..246 or 248..255. + + function Is_Upper (Item : Character) return Boolean + with + Post => Is_Upper'Result = + (Item in 'A' .. 'Z' + or else Character'Pos (Item) in 192 .. 214 | 216 .. 222); + -- True if Item is an upper-case letter. An upper-case letter is a + -- character that is in the range 'A'..'Z' or whose position is in one + -- of the ranges 192..214 or 216..222. + + function Is_Basic (Item : Character) return Boolean + with + Post => Is_Basic'Result = + (Item in 'A' .. 'Z' + | 'a' .. 'z' + | Latin_1.UC_AE_Diphthong + | Latin_1.LC_AE_Diphthong + | Latin_1.UC_Icelandic_Eth + | Latin_1.LC_Icelandic_Eth + | Latin_1.UC_Icelandic_Thorn + | Latin_1.LC_Icelandic_Thorn + | Latin_1.LC_German_Sharp_S); + -- True if Item is a basic letter. A basic letter is a character that + -- is in one of the ranges 'A'..'Z' and 'a'..'z', or that is one of + -- the following: UC_AE_Diphthong, LC_AE_Diphthong, UC_Icelandic_Eth, + -- LC_Icelandic_Eth, UC_Icelandic_Thorn, LC_Icelandic_Thorn, or + -- LC_German_Sharp_S. + + function Is_Digit (Item : Character) return Boolean + with + Post => Is_Digit'Result = (Item in '0' .. '9'); + -- True if Item is a decimal digit. A decimal digit is a character in the + -- range '0'..'9'. + function Is_Decimal_Digit (Item : Character) return Boolean renames Is_Digit; - function Is_Hexadecimal_Digit (Item : Character) return Boolean; - function Is_Alphanumeric (Item : Character) return Boolean; - function Is_Special (Item : Character) return Boolean; - function Is_Line_Terminator (Item : Character) return Boolean; - function Is_Mark (Item : Character) return Boolean; - function Is_Other_Format (Item : Character) return Boolean; - function Is_Punctuation_Connector (Item : Character) return Boolean; - function Is_Space (Item : Character) return Boolean; - function Is_NFKC (Item : Character) return Boolean; + + function Is_Hexadecimal_Digit (Item : Character) return Boolean + with + Post => Is_Hexadecimal_Digit'Result = + (Is_Decimal_Digit (Item) or Item in 'A' .. 'F' | 'a' .. 'f'); + -- True if Item is a hexadecimal digit. A hexadecimal digit is a character + -- that is either a decimal digit or that is in one of the ranges 'A'..'F' + -- or 'a'..'f'. + + function Is_Alphanumeric (Item : Character) return Boolean + with + Post => Is_Alphanumeric'Result = + (Is_Letter (Item) or Is_Decimal_Digit (Item)); + -- True if Item is an alphanumeric character. An alphanumeric character is + -- a character that is either a letter or a decimal digit. + + function Is_Special (Item : Character) return Boolean + with + Post => Is_Special'Result = + (Is_Graphic (Item) and not Is_Alphanumeric (Item)); + -- True if Item is a special graphic character. A special graphic character + -- is a graphic character that is not alphanumeric. + + function Is_Line_Terminator (Item : Character) return Boolean + with + Post => Is_Line_Terminator'Result = + (Character'Pos (Item) in 10 .. 13 | 133); + -- True if Item is a character with position 10..13 (Line_Feed, + -- Line_Tabulation, Form_Feed, Carriage_Return) or 133 (Next_Line). + + function Is_Mark (Item : Character) return Boolean + with + Post => Is_Mark'Result = False; + -- Never True (no value of type Character has categories Mark, Non-Spacing + -- or Mark, Spacing Combining). + + function Is_Other_Format (Item : Character) return Boolean + with + Post => Is_Other_Format'Result = (Character'Pos (Item) = 173); + -- True if Item is a character with position 173 (Soft_Hyphen). + + function Is_Punctuation_Connector (Item : Character) return Boolean + with + Post => Is_Punctuation_Connector'Result = + (Character'Pos (Item) = 95); + -- True if Item is a character with position 95 ('_', known as Low_Line or + -- Underscore). + + function Is_Space (Item : Character) return Boolean + with + Post => Is_Space'Result = (Character'Pos (Item) in 32 | 160); + -- True if Item is a character with position 32 (' ') or 160 + -- (No_Break_Space). + + function Is_NFKC (Item : Character) return Boolean + with + Post => Is_NFKC'Result = + (Character'Pos (Item) not in + 160 | 168 | 170 | 175 | 178 | 179 | 180 + | 181 | 184 | 185 | 186 | 188 | 189 | 190); + -- True if Item could be present in a string normalized to Normalization + -- Form KC (as defined by Clause 21 of ISO/IEC 10646:2017); this includes + -- all characters except those with positions 160, 168, 170, 175, 178, 179, + -- 180, 181, 184, 185, 186, 188, 189, and 190. --------------------------------------------------- -- Conversion Functions for Character and String -- --------------------------------------------------- - function To_Lower (Item : Character) return Character; - function To_Upper (Item : Character) return Character; - function To_Basic (Item : Character) return Character; + -- Each of the names To_Lower, To_Upper, and To_Basic refers to two + -- functions: one that converts from Character to Character, and + -- the other that converts from String to String. The result of each + -- Character-to-Character function is described below, in terms of + -- the conversion applied to Item, its formal Character parameter. The + -- result of each String-to-String conversion is obtained by applying + -- to each element of the function's String parameter the corresponding + -- Character-to-Character conversion; the result is the null String if the + -- value of the formal parameter is the null String. The lower bound of the + -- result String is 1. + + function To_Lower (Item : Character) return Character + with + Post => To_Lower'Result = + (if Is_Upper (Item) then + Character'Val (Character'Pos (Item) + + (if Item in 'A' .. 'Z' then + Character'Pos ('a') - Character'Pos ('A') + else + Character'Pos (Latin_1.LC_A_Grave) + - Character'Pos (Latin_1.UC_A_Grave))) + else + Item); + -- Returns the corresponding lower-case value for Item if Is_Upper(Item), + -- and returns Item otherwise. - function To_Lower (Item : String) return String; - function To_Upper (Item : String) return String; - function To_Basic (Item : String) return String; + function To_Upper (Item : Character) return Character + with + Post => To_Upper'Result = + (if Is_Lower (Item) + and then Item not in Latin_1.LC_German_Sharp_S + | Latin_1.LC_Y_Diaeresis + then + Character'Val (Character'Pos (Item) + + (if Item in 'A' .. 'Z' then + Character'Pos ('A') - Character'Pos ('a') + else + Character'Pos (Latin_1.UC_A_Grave) + - Character'Pos (Latin_1.LC_A_Grave))) + else + Item); + -- Returns the corresponding upper-case value for Item if Is_Lower(Item) + -- and Item has an upper-case form, and returns Item otherwise. The lower + -- case letters LC_German_Sharp_S and LC_Y_Diaeresis do not have upper case + -- forms. + + function To_Basic (Item : Character) return Character + with + Post => To_Basic'Result = + (if not Is_Letter (Item) or else Is_Basic (Item) then + Item + else + (case Item is + when Latin_1.UC_A_Grave .. Latin_1.UC_A_Ring => 'A', + when Latin_1.UC_C_Cedilla => 'C', + when Latin_1.UC_E_Grave .. Latin_1.UC_E_Diaeresis => 'E', + when Latin_1.UC_I_Grave .. Latin_1.UC_I_Diaeresis => 'I', + when Latin_1.UC_N_Tilde => 'N', + when Latin_1.UC_O_Grave .. Latin_1.UC_O_Diaeresis => 'O', + when Latin_1.UC_O_Oblique_Stroke => 'O', + when Latin_1.UC_U_Grave .. Latin_1.UC_U_Diaeresis => 'U', + when Latin_1.UC_Y_Acute => 'Y', + when Latin_1.LC_A_Grave .. Latin_1.LC_A_Ring => 'a', + when Latin_1.LC_C_Cedilla => 'c', + when Latin_1.LC_E_Grave .. Latin_1.LC_E_Diaeresis => 'e', + when Latin_1.LC_I_Grave .. Latin_1.LC_I_Diaeresis => 'i', + when Latin_1.LC_N_Tilde => 'n', + when Latin_1.LC_O_Grave .. Latin_1.LC_O_Diaeresis => 'o', + when Latin_1.LC_O_Oblique_Stroke => 'o', + when Latin_1.LC_U_Grave .. Latin_1.LC_U_Diaeresis => 'u', + when Latin_1.LC_Y_Acute => 'y', + when Latin_1.LC_Y_Diaeresis => 'y', + when others => raise Program_Error)); + -- Returns the letter corresponding to Item but with no diacritical mark, + -- if Item is a letter but not a basic letter; returns Item otherwise. + + function To_Lower (Item : String) return String + with + Post => To_Lower'Result'First = 1 + and then To_Lower'Result'Length = Item'Length + and then + (for all J in To_Lower'Result'Range => + To_Lower'Result (J) = To_Lower (Item (Item'First + (J - 1)))); + + function To_Upper (Item : String) return String + with + Post => To_Upper'Result'First = 1 + and then To_Upper'Result'Length = Item'Length + and then + (for all J in To_Upper'Result'Range => + To_Upper'Result (J) = To_Upper (Item (Item'First + (J - 1)))); + + function To_Basic (Item : String) return String + with + Post => To_Basic'Result'First = 1 + and then To_Basic'Result'Length = Item'Length + and then + (for all J in To_Basic'Result'Range => + To_Basic'Result (J) = To_Basic (Item (Item'First + (J - 1)))); ---------------------------------------------------------------------- -- Classifications of and Conversions Between Character and ISO 646 -- ---------------------------------------------------------------------- + -- The following set of functions test for membership in the ISO 646 + -- character range, or convert between ISO 646 and Character. + subtype ISO_646 is Character range Character'Val (0) .. Character'Val (127); - function Is_ISO_646 (Item : Character) return Boolean; - function Is_ISO_646 (Item : String) return Boolean; + function Is_ISO_646 (Item : Character) return Boolean + with + Post => Is_ISO_646'Result = (Item in ISO_646); + -- The function whose formal parameter, Item, is of type Character returns + -- True if Item is in the subtype ISO_646. + + function Is_ISO_646 (Item : String) return Boolean + with + Post => Is_ISO_646'Result = + (for all J in Item'Range => Is_ISO_646 (Item (J))); + -- The function whose formal parameter, Item, is of type String returns + -- True if Is_ISO_646(Item(I)) is True for each I in Item'Range. function To_ISO_646 (Item : Character; - Substitute : ISO_646 := ' ') return ISO_646; + Substitute : ISO_646 := ' ') return ISO_646 + with + Post => To_ISO_646'Result = + (if Is_ISO_646 (Item) then Item else Substitute); + -- The function whose first formal parameter, Item, is of type Character + -- returns Item if Is_ISO_646(Item), and returns the Substitute ISO_646 + -- character otherwise. function To_ISO_646 (Item : String; - Substitute : ISO_646 := ' ') return String; + Substitute : ISO_646 := ' ') return String + with + Post => To_ISO_646'Result'First = 1 + and then To_ISO_646'Result'Length = Item'Length + and then + (for all J in To_ISO_646'Result'Range => + To_ISO_646'Result (J) = + To_ISO_646 (Item (Item'First + (J - 1)), Substitute)); + -- The function whose first formal parameter, Item, is of type String + -- returns the String whose Range is 1..Item'Length and each of whose + -- elements is given by To_ISO_646 of the corresponding element in Item. ------------------------------------------------------ -- Classifications of Wide_Character and Characters -- @@ -103,8 +354,18 @@ package Ada.Characters.Handling is -- We do however have to flag these if the pragma No_Obsolescent_Features -- restriction is active (see Restrict.Check_Obsolescent_2005_Entity). - function Is_Character (Item : Wide_Character) return Boolean; - function Is_String (Item : Wide_String) return Boolean; + function Is_Character (Item : Wide_Character) return Boolean + with + Post => Is_Character'Result = + (Wide_Character'Pos (Item) <= Character'Pos (Character'Last)); + -- Returns True if Wide_Character'Pos(Item) <= + -- Character'Pos(Character'Last). + + function Is_String (Item : Wide_String) return Boolean + with + Post => Is_String'Result = + (for all I in Item'Range => Is_Character (Item (I))); + -- Returns True if Is_Character(Item(I)) is True for each I in Item'Range. ------------------------------------------------------ -- Conversions between Wide_Character and Character -- @@ -121,17 +382,49 @@ package Ada.Characters.Handling is function To_Character (Item : Wide_Character; - Substitute : Character := ' ') return Character; + Substitute : Character := ' ') return Character + with + Post => To_Character'Result = + (if Is_Character (Item) then + Character'Val (Wide_Character'Pos (Item)) + else + Substitute); + -- Returns the Character corresponding to Item if Is_Character(Item), and + -- returns the Substitute Character otherwise. function To_String (Item : Wide_String; - Substitute : Character := ' ') return String; + Substitute : Character := ' ') return String + with + Post => To_String'Result'First = 1 + and then To_String'Result'Length = Item'Length + and then + (for all J in To_String'Result'Range => + To_String'Result (J) = + To_Character (Item (Item'First + (J - 1)), Substitute)); + -- Returns the String whose range is 1..Item'Length and each of whose + -- elements is given by To_Character of the corresponding element in Item. function To_Wide_Character - (Item : Character) return Wide_Character; + (Item : Character) return Wide_Character + with + Post => To_Wide_Character'Result = + Wide_Character'Val (Character'Pos (Item)); + -- Returns the Wide_Character X such that Character'Pos(Item) = + -- Wide_Character'Pos (X). function To_Wide_String - (Item : String) return Wide_String; + (Item : String) return Wide_String + with + Post => To_Wide_String'Result'First = 1 + and then To_Wide_String'Result'Length = Item'Length + and then + (for all J in To_Wide_String'Result'Range => + To_Wide_String'Result (J) = + To_Wide_Character (Item (Item'First + (J - 1)))); + -- Returns the Wide_String whose range is 1..Item'Length and each of whose + -- elements is given by To_Wide_Character of the corresponding element in + -- Item. private pragma Inline (Is_Alphanumeric); diff --git a/gcc/ada/libgnat/a-coboho.ads b/gcc/ada/libgnat/a-coboho.ads index 086f194..44269f0 100644 --- a/gcc/ada/libgnat/a-coboho.ads +++ b/gcc/ada/libgnat/a-coboho.ads @@ -70,7 +70,9 @@ package Ada.Containers.Bounded_Holders is -- System.Storage_Unit; e.g. creating Holders from 5-bit objects won't -- work. - type Holder is private; + type Holder is private + with Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization; function "=" (Left, Right : Holder) return Boolean; diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads index 67c4419..5f3e1a7 100644 --- a/gcc/ada/libgnat/a-cobove.ads +++ b/gcc/ada/libgnat/a-cobove.ads @@ -63,12 +63,11 @@ package Ada.Containers.Bounded_Vectors is Aggregate => (Empty => Empty, Add_Unnamed => Append, New_Indexed => New_Vector, - Assign_Indexed => Replace_Element); + Assign_Indexed => Replace_Element), + Preelaborable_Initialization + => Element_Type'Preelaborable_Initialization; - pragma Preelaborable_Initialization (Vector); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); + type Cursor is private with Preelaborable_Initialization; Empty_Vector : constant Vector; diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads index a4ed7e5..6d3f486 100644 --- a/gcc/ada/libgnat/a-cofove.ads +++ b/gcc/ada/libgnat/a-cofove.ads @@ -50,6 +50,7 @@ is pragma Assertion_Policy (Pre => Ignore); pragma Assertion_Policy (Post => Ignore); + pragma Assertion_Policy (Contract_Cases => Ignore); pragma Annotate (CodePeer, Skip_Analysis); subtype Extended_Index is Index_Type'Base diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb index c332afa..5933928 100644 --- a/gcc/ada/libgnat/a-except.adb +++ b/gcc/ada/libgnat/a-except.adb @@ -629,6 +629,96 @@ package body Ada.Exceptions is pragma No_Return (Rcheck_CE_Invalid_Data_Ext); pragma No_Return (Rcheck_CE_Range_Check_Ext); + -- Make all of these procedures callable from strub contexts. + -- These attributes are not visible to callers; they are made + -- visible in trans.c:build_raise_check. + + pragma Machine_Attribute (Rcheck_CE_Access_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Null_Access_Parameter, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Discriminant_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Divide_By_Zero, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Explicit_Raise, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Index_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Invalid_Data, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Length_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Null_Exception_Id, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Null_Not_Allowed, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Overflow_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Partition_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Range_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Tag_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Accessibility_Check, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Address_Of_Intrinsic, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Aliased_Parameters, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_All_Guards_Closed, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Bad_Predicated_Generic_Type, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Build_In_Place_Mismatch, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Current_Task_In_Entry_Body, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Duplicated_Entry_Address, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Explicit_Raise, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Implicit_Return, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Misaligned_Address_Value, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Missing_Return, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Non_Transportable_Actual, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Overlaid_Controlled_Object, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Potentially_Blocking_Operation, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Stream_Operation_Not_Allowed, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Stubbed_Subprogram_Called, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Unchecked_Union_Restriction, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_PE_Finalize_Raised_Exception, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_SE_Empty_Storage_Pool, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_SE_Explicit_Raise, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_SE_Infinite_Recursion, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_SE_Object_Too_Large, + "strub", "callable"); + + pragma Machine_Attribute (Rcheck_CE_Access_Check_Ext, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Index_Check_Ext, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Invalid_Data_Ext, + "strub", "callable"); + pragma Machine_Attribute (Rcheck_CE_Range_Check_Ext, + "strub", "callable"); + --------------------------------------------- -- Reason Strings for Run-Time Check Calls -- --------------------------------------------- diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads index 2b27adb..1608e79 100644 --- a/gcc/ada/libgnat/a-except.ads +++ b/gcc/ada/libgnat/a-except.ads @@ -184,6 +184,15 @@ private -- Raise_Exception_Always if it can determine this is the case. The Export -- allows this routine to be accessed from Pure units. + -- Make these callable from strub contexts. + pragma Machine_Attribute (Raise_Exception_Always, + "strub", "callable"); + pragma Machine_Attribute (Raise_Exception, + "strub", "callable"); + -- This property should arguably be visible to callers, but let's + -- keep it private for now. In practice, it doesn't matter, since + -- it's only checked in the back end. + procedure Raise_From_Controlled_Operation (X : Exception_Occurrence); pragma No_Return (Raise_From_Controlled_Operation); pragma Export diff --git a/gcc/ada/libgnat/a-strbou.adb b/gcc/ada/libgnat/a-strbou.adb index 61b3d73..01a2002 100644 --- a/gcc/ada/libgnat/a-strbou.adb +++ b/gcc/ada/libgnat/a-strbou.adb @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ -package body Ada.Strings.Bounded is +package body Ada.Strings.Bounded with SPARK_Mode is package body Generic_Bounded_Length is diff --git a/gcc/ada/libgnat/a-strbou.ads b/gcc/ada/libgnat/a-strbou.ads index f0cf7b2..e820184 100644 --- a/gcc/ada/libgnat/a-strbou.ads +++ b/gcc/ada/libgnat/a-strbou.ads @@ -33,25 +33,41 @@ -- -- ------------------------------------------------------------------------------ --- 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. - -pragma Assertion_Policy (Pre => Ignore); - -with Ada.Strings.Maps; +-- The language-defined package Strings.Bounded provides a generic package +-- each of whose instances yields a private type Bounded_String and a set +-- of operations. An object of a particular Bounded_String type represents +-- a String whose low bound is 1 and whose length can vary conceptually +-- between 0 and a maximum size established at the generic instantiation. The +-- subprograms for fixed-length string handling are either overloaded directly +-- for Bounded_String, or are modified as needed to reflect the variability in +-- length. Additionally, since the Bounded_String type is private, appropriate +-- constructor and selector operations are provided. + +with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; with Ada.Strings.Superbounded; +with Ada.Strings.Search; -package Ada.Strings.Bounded is +package Ada.Strings.Bounded with SPARK_Mode is pragma Preelaborate; generic Max : Positive; -- Maximum length of a Bounded_String - package Generic_Bounded_Length with - Initial_Condition => Length (Null_Bounded_String) = 0 + package Generic_Bounded_Length with SPARK_Mode, + Initial_Condition => Length (Null_Bounded_String) = 0, + Abstract_State => null is + -- 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. + -- Postconditions and contract cases should not be executed at runtime + -- as well, in order not to slow down the execution of these functions. + + pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore); Max_Length : constant Positive := Max; @@ -59,11 +75,16 @@ package Ada.Strings.Bounded is pragma Preelaborable_Initialization (Bounded_String); Null_Bounded_String : constant Bounded_String; + -- Null_Bounded_String represents the null string. If an object of type + -- Bounded_String is not otherwise initialized, it will be initialized + -- to the same value as Null_Bounded_String. subtype Length_Range is Natural range 0 .. Max_Length; function Length (Source : Bounded_String) return Length_Range with Global => null; + -- The Length function returns the length of the string represented by + -- Source. -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- @@ -73,163 +94,466 @@ package Ada.Strings.Bounded is (Source : String; Drop : Truncation := Error) return Bounded_String with - Pre => (if Source'Length > Max_Length then Drop /= Error), - Post => - Length (To_Bounded_String'Result) - = Natural'Min (Max_Length, Source'Length), - Global => null; + Pre => (if Source'Length > Max_Length then Drop /= Error), + Contract_Cases => + (Source'Length <= Max_Length + => + To_String (To_Bounded_String'Result) = Source, + + Source'Length > Max_Length and then Drop = Left + => + To_String (To_Bounded_String'Result) = + Source (Source'Last - Max_Length + 1 .. Source'Last), + + others -- Drop = Right + => + To_String (To_Bounded_String'Result) = + Source (Source'First .. Source'First - 1 + Max_Length)); + -- If Source'Length <= Max_Length, then this function returns a + -- Bounded_String that represents Source. Otherwise, the effect + -- depends on the value of Drop: + -- + -- * If Drop=Left, then the result is a Bounded_String that represents + -- the string comprising the rightmost Max_Length characters of + -- Source. + -- + -- * If Drop=Right, then the result is a Bounded_String that represents + -- the string comprising the leftmost Max_Length characters of Source. + -- + -- * If Drop=Error, then Strings.Length_Error is propagated. function To_String (Source : Bounded_String) return String with - Post => To_String'Result'Length = Length (Source), Global => null; + -- To_String returns the String value with lower bound 1 + -- represented by Source. If B is a Bounded_String, then + -- B = To_Bounded_String(To_String(B)). procedure Set_Bounded_String (Target : out Bounded_String; Source : String; Drop : Truncation := Error) with - Pre => (if Source'Length > Max_Length then Drop /= Error), - Post => Length (Target) = Natural'Min (Max_Length, Source'Length), - Global => null; + Pre => (if Source'Length > Max_Length then Drop /= Error), + Contract_Cases => + (Source'Length <= Max_Length + => + To_String (Target) = Source, + + Source'Length > Max_Length and then Drop = Left + => + To_String (Target) = + Source (Source'Last - Max_Length + 1 .. Source'Last), + + others -- Drop = Right + => + To_String (Target) = + Source (Source'First .. Source'First - 1 + Max_Length)); pragma Ada_05 (Set_Bounded_String); + -- Equivalent to Target := To_Bounded_String (Source, Drop); + + -- Each of the Append functions returns a Bounded_String obtained by + -- concatenating the string or character given or represented by one + -- of the parameters, with the string or character given or represented + -- by the other parameter, and applying To_Bounded_String to the + -- concatenation result string, with Drop as provided to the Append + -- function. function Append (Left : Bounded_String; Right : Bounded_String; Drop : Truncation := Error) return Bounded_String with - Pre => + Pre => (if Length (Left) > Max_Length - Length (Right) then Drop /= Error), - Post => - Length (Append'Result) - = Natural'Min (Max_Length, Length (Left) + Length (Right)), - Global => null; + Contract_Cases => + (Length (Left) <= Max_Length - Length (Right) + => + Length (Append'Result) = Length (Left) + Length (Right) + and then + Slice (Append'Result, 1, Length (Left)) = To_String (Left) + and then + (if Length (Right) > 0 then + Slice (Append'Result, + Length (Left) + 1, Length (Append'Result)) = + To_String (Right)), + + Length (Left) > Max_Length - Length (Right) + and then Drop = Strings.Left + => + Length (Append'Result) = Max_Length + and then + (if Length (Right) < Max_Length then + Slice (Append'Result, 1, Max_Length - Length (Right)) = + Slice (Left, + Length (Left) - Max_Length + Length (Right) + 1, + Length (Left))) + and then + Slice (Append'Result, + Max_Length - Length (Right) + 1, Max_Length) = + To_String (Right), + + others -- Drop = Right + => + Length (Append'Result) = Max_Length + and then + Slice (Append'Result, 1, Length (Left)) = To_String (Left) + and then + (if Length (Left) < Max_Length then + Slice (Append'Result, Length (Left) + 1, Max_Length) = + Slice (Right, 1, Max_Length - Length (Left)))); function Append (Left : Bounded_String; Right : String; Drop : Truncation := Error) return Bounded_String with - Pre => + Pre => (if Right'Length > Max_Length - Length (Left) then Drop /= Error), - Post => - Length (Append'Result) - = Natural'Min (Max_Length, Length (Left) + Right'Length), - Global => null; - + Contract_Cases => + (Length (Left) <= Max_Length - Right'Length + => + Length (Append'Result) = Length (Left) + Right'Length + and then + Slice (Append'Result, 1, Length (Left)) = To_String (Left) + and then + (if Right'Length > 0 then + Slice (Append'Result, + Length (Left) + 1, Length (Append'Result)) = + Right), + + Length (Left) > Max_Length - Right'Length + and then Drop = Strings.Left + => + Length (Append'Result) = Max_Length + and then + (if Right'Length < Max_Length then + + -- The result is the end of Left followed by Right + + Slice (Append'Result, 1, Max_Length - Right'Length) = + Slice (Left, + Length (Left) - Max_Length + Right'Length + 1, + Length (Left)) + and then + Slice (Append'Result, + Max_Length - Right'Length + 1, Max_Length) = + Right + else + -- The result is the last Max_Length characters of Right + + To_String (Append'Result) = + Right (Right'Last - Max_Length + 1 .. Right'Last)), + + others -- Drop = Right + => + Length (Append'Result) = Max_Length + and then + Slice (Append'Result, 1, Length (Left)) = To_String (Left) + and then + (if Length (Left) < Max_Length then + Slice (Append'Result, Length (Left) + 1, Max_Length) = + Right (Right'First + .. Max_Length - Length (Left) - 1 + Right'First))); function Append (Left : String; Right : Bounded_String; Drop : Truncation := Error) return Bounded_String with - Pre => + Pre => (if Left'Length > Max_Length - Length (Right) then Drop /= Error), - Post => - Length (Append'Result) - = Natural'Min (Max_Length, Left'Length + Length (Right)), - Global => null; + Contract_Cases => + (Left'Length <= Max_Length - Length (Right) + => + Length (Append'Result) = Left'Length + Length (Right) + and then Slice (Append'Result, 1, Left'Length) = Left + and then + (if Length (Right) > 0 then + Slice (Append'Result, + Left'Length + 1, Length (Append'Result)) = + To_String (Right)), + + Left'Length > Max_Length - Length (Right) + and then Drop = Strings.Left + => + Length (Append'Result) = Max_Length + and then + (if Length (Right) < Max_Length then + Slice (Append'Result, 1, Max_Length - Length (Right)) = + Left (Left'Last - Max_Length + Length (Right) + 1 + .. Left'Last)) + and then + Slice (Append'Result, + Max_Length - Length (Right) + 1, Max_Length) = + To_String (Right), + + others -- Drop = Right + => + Length (Append'Result) = Max_Length + and then + (if Left'Length < Max_Length then + + -- The result is Left followed by the beginning of Right + + Slice (Append'Result, 1, Left'Length) = Left + and then + Slice (Append'Result, Left'Length + 1, Max_Length) = + Slice (Right, 1, Max_Length - Left'Length) + else + -- The result is the first Max_Length characters of Left + + To_String (Append'Result) = + Left (Left'First .. Max_Length - 1 + Left'First))); function Append (Left : Bounded_String; Right : Character; Drop : Truncation := Error) return Bounded_String with - Pre => (if Length (Left) = Max_Length then Drop /= Error), - Post => - Length (Append'Result) - = Natural'Min (Max_Length, Length (Left) + 1), - Global => null; + Pre => (if Length (Left) = Max_Length then Drop /= Error), + Contract_Cases => + (Length (Left) < Max_Length + => + Length (Append'Result) = Length (Left) + 1 + and then + Slice (Append'Result, 1, Length (Left)) = To_String (Left) + and then Element (Append'Result, Length (Left) + 1) = Right, + + Length (Left) = Max_Length and then Drop = Strings.Right + => + Length (Append'Result) = Max_Length + and then To_String (Append'Result) = To_String (Left), + + others -- Drop = Left + => + Length (Append'Result) = Max_Length + and then + Slice (Append'Result, 1, Max_Length - 1) = + Slice (Left, 2, Max_Length) + and then Element (Append'Result, Max_Length) = Right); function Append (Left : Character; Right : Bounded_String; Drop : Truncation := Error) return Bounded_String with - Pre => (if Length (Right) = Max_Length then Drop /= Error), - Post => - Length (Append'Result) - = Natural'Min (Max_Length, 1 + Length (Right)), - Global => null; + Pre => (if Length (Right) = Max_Length then Drop /= Error), + Contract_Cases => + (Length (Right) < Max_Length + => + Length (Append'Result) = Length (Right) + 1 + and then + Slice (Append'Result, 2, Length (Right) + 1) = + To_String (Right) + and then Element (Append'Result, 1) = Left, + + Length (Right) = Max_Length and then Drop = Strings.Left + => + Length (Append'Result) = Max_Length + and then To_String (Append'Result) = To_String (Right), + + others -- Drop = Right + => + Length (Append'Result) = Max_Length + and then + Slice (Append'Result, 2, Max_Length) = + Slice (Right, 1, Max_Length - 1) + and then Element (Append'Result, 1) = Left); + + -- Each of the procedures Append(Source, New_Item, Drop) has the same + -- effect as the corresponding assignment + -- Source := Append(Source, New_Item, Drop). procedure Append (Source : in out Bounded_String; New_Item : Bounded_String; Drop : Truncation := Error) with - Pre => + Pre => (if Length (Source) > Max_Length - Length (New_Item) then Drop /= Error), - Post => - Length (Source) - = Natural'Min (Max_Length, Length (Source)'Old + Length (New_Item)), - Global => null; + Contract_Cases => + (Length (Source) <= Max_Length - Length (New_Item) + => + Length (Source) = Length (Source'Old) + Length (New_Item) + and then + Slice (Source, 1, Length (Source'Old)) = + To_String (Source'Old) + and then + (if Length (New_Item) > 0 then + Slice (Source, Length (Source'Old) + 1, Length (Source)) = + To_String (New_Item)), + + Length (Source) > Max_Length - Length (New_Item) + and then Drop = Left + => + Length (Source) = Max_Length + and then + (if Length (New_Item) < Max_Length then + Slice (Source, 1, Max_Length - Length (New_Item)) = + Slice (Source'Old, + Length (Source'Old) - Max_Length + Length (New_Item) + + 1, + Length (Source'Old))) + and then + Slice (Source, Max_Length - Length (New_Item) + 1, Max_Length) + = To_String (New_Item), + + others -- Drop = Right + => + Length (Source) = Max_Length + and then + Slice (Source, 1, Length (Source'Old)) = + To_String (Source'Old) + and then + (if Length (Source'Old) < Max_Length then + Slice (Source, Length (Source'Old) + 1, Max_Length) = + Slice (New_Item, 1, Max_Length - Length (Source'Old)))); procedure Append (Source : in out Bounded_String; New_Item : String; Drop : Truncation := Error) with - Pre => + Pre => (if New_Item'Length > Max_Length - Length (Source) then Drop /= Error), - Post => - Length (Source) - = Natural'Min (Max_Length, Length (Source)'Old + New_Item'Length), - Global => null; + Contract_Cases => + (Length (Source) <= Max_Length - New_Item'Length + => + Length (Source) = Length (Source'Old) + New_Item'Length + and then + Slice (Source, 1, Length (Source'Old)) = + To_String (Source'Old) + and then + (if New_Item'Length > 0 then + Slice (Source, Length (Source'Old) + 1, Length (Source)) = + New_Item), + + Length (Source) > Max_Length - New_Item'Length + and then Drop = Left + => + Length (Source) = Max_Length + and then + (if New_Item'Length < Max_Length then + + -- The result is the end of Source followed by New_Item + + Slice (Source, 1, Max_Length - New_Item'Length) = + Slice (Source'Old, + Length (Source'Old) - Max_Length + New_Item'Length + 1, + Length (Source'Old)) + and then + Slice (Source, + Max_Length - New_Item'Length + 1, Max_Length) = + New_Item + else + -- The result is the last Max_Length characters of + -- New_Item. + + To_String (Source) = New_Item + (New_Item'Last - Max_Length + 1 .. New_Item'Last)), + + others -- Drop = Right + => + Length (Source) = Max_Length + and then + Slice (Source, 1, Length (Source'Old)) = + To_String (Source'Old) + and then + (if Length (Source'Old) < Max_Length then + Slice (Source, Length (Source'Old) + 1, Max_Length) = + New_Item (New_Item'First + .. Max_Length - Length (Source'Old) - 1 + + New_Item'First))); procedure Append (Source : in out Bounded_String; New_Item : Character; Drop : Truncation := Error) with - Pre => (if Length (Source) = Max_Length then Drop /= Error), - Post => - Length (Source) - = Natural'Min (Max_Length, Length (Source)'Old + 1), - Global => null; + Pre => (if Length (Source) = Max_Length then Drop /= Error), + Contract_Cases => + (Length (Source) < Max_Length + => + Length (Source) = Length (Source'Old) + 1 + and then + Slice (Source, 1, Length (Source'Old)) = + To_String (Source'Old) + and then Element (Source, Length (Source'Old) + 1) = New_Item, + + Length (Source) = Max_Length and then Drop = Right + => + Length (Source) = Max_Length + and then To_String (Source) = To_String (Source'Old), + + others -- Drop = Left + => + Length (Source) = Max_Length + and then + Slice (Source, 1, Max_Length - 1) = + Slice (Source'Old, 2, Max_Length) + and then Element (Source, Max_Length) = New_Item); + + -- Each of the "&" functions has the same effect as the corresponding + -- Append function, with Error as the Drop parameter. function "&" (Left : Bounded_String; Right : Bounded_String) return Bounded_String with - Pre => Length (Left) <= Max_Length - Length (Right), - Post => Length ("&"'Result) = Length (Left) + Length (Right), - Global => null; + Pre => Length (Left) <= Max_Length - Length (Right), + Post => Length ("&"'Result) = Length (Left) + Length (Right) + and then Slice ("&"'Result, 1, Length (Left)) = To_String (Left) + and then + (if Length (Right) > 0 then + Slice ("&"'Result, Length (Left) + 1, Length ("&"'Result)) = + To_String (Right)); function "&" (Left : Bounded_String; Right : String) return Bounded_String with - Pre => Right'Length <= Max_Length - Length (Left), - Post => Length ("&"'Result) = Length (Left) + Right'Length, - Global => null; + Pre => Right'Length <= Max_Length - Length (Left), + Post => Length ("&"'Result) = Length (Left) + Right'Length + and then Slice ("&"'Result, 1, Length (Left)) = To_String (Left) + and then + (if Right'Length > 0 then + Slice ("&"'Result, Length (Left) + 1, Length ("&"'Result)) = + Right); function "&" (Left : String; Right : Bounded_String) return Bounded_String with - Pre => Left'Length <= Max_Length - Length (Right), - Post => Length ("&"'Result) = Left'Length + Length (Right), - Global => null; + Pre => Left'Length <= Max_Length - Length (Right), + Post => Length ("&"'Result) = Left'Length + Length (Right) + and then Slice ("&"'Result, 1, Left'Length) = Left + and then + (if Length (Right) > 0 then + Slice ("&"'Result, Left'Length + 1, Length ("&"'Result)) = + To_String (Right)); function "&" (Left : Bounded_String; Right : Character) return Bounded_String with - Pre => Length (Left) < Max_Length, - Post => Length ("&"'Result) = Length (Left) + 1, - Global => null; + Pre => Length (Left) < Max_Length, + Post => Length ("&"'Result) = Length (Left) + 1 + and then Slice ("&"'Result, 1, Length (Left)) = To_String (Left) + and then Element ("&"'Result, Length (Left) + 1) = Right; function "&" (Left : Character; Right : Bounded_String) return Bounded_String with - Pre => Length (Right) < Max_Length, - Post => Length ("&"'Result) = 1 + Length (Right), - Global => null; + Pre => Length (Right) < Max_Length, + Post => Length ("&"'Result) = 1 + Length (Right) + and then Element ("&"'Result, 1) = Left + and then + Slice ("&"'Result, 2, Length ("&"'Result)) = To_String (Right); function Element (Source : Bounded_String; @@ -237,6 +561,8 @@ package Ada.Strings.Bounded is with Pre => Index <= Length (Source), Global => null; + -- Returns the character at position Index in the string represented by + -- Source; propagates Index_Error if Index > Length(Source). procedure Replace_Element (Source : in out Bounded_String; @@ -244,8 +570,14 @@ package Ada.Strings.Bounded is By : Character) with Pre => Index <= Length (Source), - Post => Length (Source) = Length (Source)'Old, + Post => Length (Source) = Length (Source'Old) + and then (for all K in 1 .. Length (Source) => + Element (Source, K) = + (if K = Index then By else Element (Source'Old, K))), Global => null; + -- Updates Source such that the character at position Index in the + -- string represented by Source is By; propagates Index_Error if + -- Index > Length(Source). function Slice (Source : Bounded_String; @@ -253,8 +585,11 @@ package Ada.Strings.Bounded is High : Natural) return String with Pre => Low - 1 <= Length (Source) and then High <= Length (Source), - Post => Slice'Result'Length = Natural'Max (0, High - Low + 1), Global => null; + -- Returns the slice at positions Low through High in the + -- string represented by Source; propagates Index_Error if + -- Low > Length(Source)+1 or High > Length(Source). + -- The bounds of the returned string are Low and High. function Bounded_Slice (Source : Bounded_String; @@ -262,10 +597,12 @@ package Ada.Strings.Bounded is High : Natural) return Bounded_String with Pre => Low - 1 <= Length (Source) and then High <= Length (Source), - Post => - Length (Bounded_Slice'Result) = Natural'Max (0, High - Low + 1), + Post => To_String (Bounded_Slice'Result) = Slice (Source, Low, High), Global => null; pragma Ada_05 (Bounded_Slice); + -- Returns the slice at positions Low through High in the string + -- represented by Source as a bounded string; propagates Index_Error + -- if Low > Length(Source)+1 or High > Length(Source). procedure Bounded_Slice (Source : Bounded_String; @@ -274,112 +611,181 @@ package Ada.Strings.Bounded is High : Natural) with Pre => Low - 1 <= Length (Source) and then High <= Length (Source), - Post => Length (Target) = Natural'Max (0, High - Low + 1), + Post => To_String (Target) = Slice (Source, Low, High), Global => null; pragma Ada_05 (Bounded_Slice); + -- Equivalent to Target := Bounded_Slice (Source, Low, High); + + -- Each of the functions "=", "<", ">", "<=", and ">=" returns the same + -- result as the corresponding String operation applied to the String + -- values given or represented by the two parameters. function "=" (Left : Bounded_String; Right : Bounded_String) return Boolean with + Post => "="'Result = (To_String (Left) = To_String (Right)), Global => null; function "=" (Left : Bounded_String; Right : String) return Boolean with + Post => "="'Result = (To_String (Left) = Right), Global => null; function "=" (Left : String; Right : Bounded_String) return Boolean with + Post => "="'Result = (Left = To_String (Right)), Global => null; function "<" (Left : Bounded_String; Right : Bounded_String) return Boolean with + Post => "<"'Result = (To_String (Left) < To_String (Right)), Global => null; function "<" (Left : Bounded_String; Right : String) return Boolean with + Post => "<"'Result = (To_String (Left) < Right), Global => null; function "<" (Left : String; Right : Bounded_String) return Boolean with + Post => "<"'Result = (Left < To_String (Right)), Global => null; function "<=" (Left : Bounded_String; Right : Bounded_String) return Boolean with + Post => "<="'Result = (To_String (Left) <= To_String (Right)), Global => null; function "<=" (Left : Bounded_String; Right : String) return Boolean with + Post => "<="'Result = (To_String (Left) <= Right), Global => null; function "<=" (Left : String; Right : Bounded_String) return Boolean with + Post => "<="'Result = (Left <= To_String (Right)), Global => null; function ">" (Left : Bounded_String; Right : Bounded_String) return Boolean with + Post => ">"'Result = (To_String (Left) > To_String (Right)), Global => null; function ">" (Left : Bounded_String; Right : String) return Boolean with + Post => ">"'Result = (To_String (Left) > Right), Global => null; function ">" (Left : String; Right : Bounded_String) return Boolean with + Post => ">"'Result = (Left > To_String (Right)), Global => null; function ">=" (Left : Bounded_String; Right : Bounded_String) return Boolean with + Post => ">="'Result = (To_String (Left) >= To_String (Right)), Global => null; function ">=" (Left : Bounded_String; Right : String) return Boolean with + Post => ">="'Result = (To_String (Left) >= Right), Global => null; function ">=" (Left : String; Right : Bounded_String) return Boolean with + Post => ">="'Result = (Left >= To_String (Right)), Global => null; ---------------------- -- Search Functions -- ---------------------- + -- Each of the search subprograms (Index, Index_Non_Blank, Count, + -- Find_Token) has the same effect as the corresponding subprogram in + -- Strings.Fixed applied to the string represented by the Bounded_String + -- parameter. + function Index (Source : Bounded_String; Pattern : String; Going : Direction := Forward; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural with - Pre => Pattern'Length /= 0, - Global => null; + Pre => Pattern'Length > 0, + Post => Index'Result <= Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Length (Source) = 0 + => + Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Length (Source) > 0 + and then + (for some J in 1 .. Length (Source) - (Pattern'Length - 1) => + Search.Match (To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Index'Result in 1 .. Length (Source) - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (To_String (Source), Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Length (Source) => + (if (if Going = Forward + then J <= Index'Result - 1 + else J - 1 in Index'Result + .. Length (Source) - Pattern'Length) + then not (Search.Match + (To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), + Global => null; function Index (Source : Bounded_String; @@ -387,8 +793,52 @@ package Ada.Strings.Bounded is Going : Direction := Forward; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => Pattern'Length /= 0, - Global => null; + Pre => Pattern'Length /= 0 and then Mapping /= null, + Post => Index'Result <= Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Length (Source) = 0 + => + Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Length (Source) > 0 + and then + (for some J in 1 .. Length (Source) - (Pattern'Length - 1) => + Search.Match (To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Index'Result in 1 .. Length (Source) - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (To_String (Source), Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Length (Source) => + (if (if Going = Forward + then J <= Index'Result - 1 + else J - 1 in Index'Result + .. Length (Source) - Pattern'Length) + then not (Search.Match + (To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), + Global => null; function Index (Source : Bounded_String; @@ -396,7 +846,43 @@ package Ada.Strings.Bounded is Test : Membership := Inside; Going : Direction := Forward) return Natural with - Global => null; + Post => Index'Result <= Length (Source), + Contract_Cases => + + -- If no character of Source satisfies the property Test on Set, + -- then 0 is returned. + + ((for all C of To_String (Source) => + (Test = Inside) /= Maps.Is_In (C, Set)) + => + Index'Result = 0, + + -- Otherwise, an index in the range of Source is returned + + others + => + -- The result is in the range of Source + + Index'Result in 1 .. Length (Source) + + -- The character at the returned index satisfies the property + -- Test on Set. + + and then + (Test = Inside) = + Maps.Is_In (Element (Source, Index'Result), Set) + + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Length (Source) => + (if J /= Index'Result + and then (J < Index'Result) = (Going = Forward) + then (Test = Inside) + /= Maps.Is_In (Element (Source, J), Set)))), + Global => null; function Index (Source : Bounded_String; @@ -405,11 +891,60 @@ package Ada.Strings.Bounded is Going : Direction := Forward; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural with - Pre => - (if Length (Source) /= 0 - then From <= Length (Source)) - and then Pattern'Length /= 0, - Global => null; + Pre => + (if Length (Source) /= 0 then From <= Length (Source)) + and then Pattern'Length /= 0, + Post => Index'Result <= Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Length (Source) = 0 + => + Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Length (Source) > 0 + and then + (for some J in + (if Going = Forward then From else 1) + .. (if Going = Forward then Length (Source) else From) + - (Pattern'Length - 1) => + Search.Match (To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Index'Result in + (if Going = Forward then From else 1) + .. (if Going = Forward then Length (Source) else From) + - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (To_String (Source), Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Length (Source) => + (if (if Going = Forward + then J in From .. Index'Result - 1 + else J - 1 in Index'Result + .. From - Pattern'Length) + then not (Search.Match + (To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), + Global => null; pragma Ada_05 (Index); function Index @@ -419,11 +954,61 @@ package Ada.Strings.Bounded is Going : Direction := Forward; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => - (if Length (Source) /= 0 - then From <= Length (Source)) - and then Pattern'Length /= 0, - Global => null; + Pre => + (if Length (Source) /= 0 then From <= Length (Source)) + and then Pattern'Length /= 0 + and then Mapping /= null, + Post => Index'Result <= Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Length (Source) = 0 + => + Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Length (Source) > 0 + and then + (for some J in + (if Going = Forward then From else 1) + .. (if Going = Forward then Length (Source) else From) + - (Pattern'Length - 1) => + Search.Match (To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Index'Result in + (if Going = Forward then From else 1) + .. (if Going = Forward then Length (Source) else From) + - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (To_String (Source), Pattern, Mapping, Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Length (Source) => + (if (if Going = Forward + then J in From .. Index'Result - 1 + else J - 1 in Index'Result + .. From - Pattern'Length) + then not (Search.Match + (To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Index'Result = 0), + Global => null; pragma Ada_05 (Index); function Index @@ -433,23 +1018,147 @@ package Ada.Strings.Bounded is Test : Membership := Inside; Going : Direction := Forward) return Natural with - Pre => (if Length (Source) /= 0 then From <= Length (Source)), - Global => null; + Pre => + (if Length (Source) /= 0 then From <= Length (Source)), + Post => Index'Result <= Length (Source), + Contract_Cases => + + -- If Source is the empty string, or no character of the considered + -- slice of Source satisfies the property Test on Set, then 0 is + -- returned. + + (Length (Source) = 0 + or else + (for all J in 1 .. Length (Source) => + (if J = From or else (J > From) = (Going = Forward) then + (Test = Inside) /= Maps.Is_In (Element (Source, J), Set))) + => + Index'Result = 0, + + -- Otherwise, an index in the considered range of Source is + -- returned. + + others + => + -- The result is in the considered range of Source + + Index'Result in 1 .. Length (Source) + and then + (Index'Result = From + or else (Index'Result > From) = (Going = Forward)) + + -- The character at the returned index satisfies the property + -- Test on Set. + + and then + (Test = Inside) = + Maps.Is_In (Element (Source, Index'Result), Set) + + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Length (Source) => + (if J /= Index'Result + and then (J < Index'Result) = (Going = Forward) + and then (J = From + or else (J > From) = (Going = Forward)) + then (Test = Inside) + /= Maps.Is_In (Element (Source, J), Set)))), + Global => null; pragma Ada_05 (Index); function Index_Non_Blank (Source : Bounded_String; Going : Direction := Forward) return Natural with - Global => null; + Post => Index_Non_Blank'Result <= Length (Source), + Contract_Cases => + + -- If all characters of Source are Space characters, then 0 is + -- returned. + + ((for all C of To_String (Source) => C = ' ') + => + Index_Non_Blank'Result = 0, + + -- Otherwise, an index in the range of Source is returned + + others + => + -- The result is in the range of Source + + Index_Non_Blank'Result in 1 .. Length (Source) + + -- The character at the returned index is not a Space character + + and then Element (Source, Index_Non_Blank'Result) /= ' ' + + -- The result is the smallest or largest index which is not a + -- Space character, respectively when Going = Forward and Going + -- = Backward. + + and then + (for all J in 1 .. Length (Source) => + (if J /= Index_Non_Blank'Result + and then + (J < Index_Non_Blank'Result) = (Going = Forward) + then Element (Source, J) = ' '))), + Global => null; function Index_Non_Blank (Source : Bounded_String; From : Positive; Going : Direction := Forward) return Natural with - Pre => (if Length (Source) /= 0 then From <= Length (Source)), - Global => null; + Pre => + (if Length (Source) /= 0 then From <= Length (Source)), + Post => Index_Non_Blank'Result <= Length (Source), + Contract_Cases => + + -- If Source is the empty string, or all characters of the + -- considered slice of Source are Space characters, then 0 + -- is returned. + + (Length (Source) = 0 + or else + (for all J in 1 .. Length (Source) => + (if J = From or else (J > From) = (Going = Forward) then + Element (Source, J) = ' ')) + => + Index_Non_Blank'Result = 0, + + -- Otherwise, an index in the considered range of Source is + -- returned. + + others + => + -- The result is in the considered range of Source + + Index_Non_Blank'Result in 1 .. Length (Source) + and then + (Index_Non_Blank'Result = From + or else + (Index_Non_Blank'Result > From) = (Going = Forward)) + + -- The character at the returned index is not a Space character + + and then Element (Source, Index_Non_Blank'Result) /= ' ' + + -- The result is the smallest or largest index which isn't a + -- Space character, respectively when Going = Forward and Going + -- = Backward. + + and then + (for all J in 1 .. Length (Source) => + (if J /= Index_Non_Blank'Result + and then + (J < Index_Non_Blank'Result) = (Going = Forward) + and then (J = From + or else (J > From) = (Going = Forward)) + then Element (Source, J) = ' '))), + Global => null; pragma Ada_05 (Index_Non_Blank); function Count @@ -465,7 +1174,7 @@ package Ada.Strings.Bounded is Pattern : String; Mapping : Maps.Character_Mapping_Function) return Natural with - Pre => Pattern'Length /= 0, + Pre => Pattern'Length /= 0 and then Mapping /= null, Global => null; function Count @@ -482,8 +1191,53 @@ package Ada.Strings.Bounded is First : out Positive; Last : out Natural) with - Pre => (if Length (Source) /= 0 then From <= Length (Source)), - Global => null; + Pre => + (if Length (Source) /= 0 then From <= Length (Source)), + Contract_Cases => + + -- If Source is the empty string, or if no character of the + -- considered slice of Source satisfies the property Test on + -- Set, then First is set to From and Last is set to 0. + + (Length (Source) = 0 + or else + (for all J in From .. Length (Source) => + (Test = Inside) /= Maps.Is_In (Element (Source, J), Set)) + => + First = From and then Last = 0, + + -- Otherwise, First and Last are set to valid indexes + + others + => + -- First and Last are in the considered range of Source + + First in From .. Length (Source) + and then Last in First .. Length (Source) + + -- No character between From and First satisfies the property + -- Test on Set. + + and then + (for all J in From .. First - 1 => + (Test = Inside) /= Maps.Is_In (Element (Source, J), Set)) + + -- All characters between First and Last satisfy the property + -- Test on Set. + + and then + (for all J in First .. Last => + (Test = Inside) = Maps.Is_In (Element (Source, J), Set)) + + -- If Last is not Source'Last, then the character at position + -- Last + 1 does not satify the property Test on Set. + + and then + (if Last < Length (Source) + then + (Test = Inside) + /= Maps.Is_In (Element (Source, Last + 1), Set))), + Global => null; pragma Ada_2012 (Find_Token); procedure Find_Token @@ -493,44 +1247,127 @@ package Ada.Strings.Bounded is First : out Positive; Last : out Natural) with - Global => null; + Contract_Cases => + + -- If Source is the empty string, or if no character of the + -- considered slice of Source satisfies the property Test on + -- Set, then First is set to 1 and Last is set to 0. + + (Length (Source) = 0 + or else + (for all J in 1 .. Length (Source) => + (Test = Inside) /= Maps.Is_In (Element (Source, J), Set)) + => + First = 1 and then Last = 0, + + -- Otherwise, First and Last are set to valid indexes + + others + => + -- First and Last are in the considered range of Source + + First in 1 .. Length (Source) + and then Last in First .. Length (Source) + + -- No character between 1 and First satisfies the property Test + -- on Set. + + and then + (for all J in 1 .. First - 1 => + (Test = Inside) /= Maps.Is_In (Element (Source, J), Set)) + + -- All characters between First and Last satisfy the property + -- Test on Set. + + and then + (for all J in First .. Last => + (Test = Inside) = Maps.Is_In (Element (Source, J), Set)) + + -- If Last is not Source'Last, then the character at position + -- Last + 1 does not satify the property Test on Set. + + and then + (if Last < Length (Source) + then + (Test = Inside) + /= Maps.Is_In (Element (Source, Last + 1), Set))), + Global => null; ------------------------------------ -- String Translation Subprograms -- ------------------------------------ + -- Each of the Translate subprograms, when applied to a Bounded_String, + -- has an analogous effect to the corresponding subprogram in + -- Strings.Fixed. For the Translate function, the translation is applied + -- to the string represented by the Bounded_String parameter, and the + -- result is converted (via To_Bounded_String) to a Bounded_String. For + -- the Translate procedure, the string represented by the Bounded_String + -- parameter after the translation is given by the Translate function + -- for fixed-length strings applied to the string represented by the + -- original value of the parameter. + function Translate (Source : Bounded_String; Mapping : Maps.Character_Mapping) return Bounded_String with - Post => Length (Translate'Result) = Length (Source), + Post => Length (Translate'Result) = Length (Source) + and then + (for all K in 1 .. Length (Source) => + Element (Translate'Result, K) = + Ada.Strings.Maps.Value (Mapping, Element (Source, K))), Global => null; procedure Translate (Source : in out Bounded_String; Mapping : Maps.Character_Mapping) with - Post => Length (Source) = Length (Source)'Old, + Post => Length (Source) = Length (Source'Old) + and then + (for all K in 1 .. Length (Source) => + Element (Source, K) = + Ada.Strings.Maps.Value (Mapping, Element (Source'Old, K))), Global => null; function Translate (Source : Bounded_String; Mapping : Maps.Character_Mapping_Function) return Bounded_String with - Post => Length (Translate'Result) = Length (Source), + Pre => Mapping /= null, + Post => Length (Translate'Result) = Length (Source) + and then + (for all K in 1 .. Length (Source) => + Element (Translate'Result, K) = Mapping (Element (Source, K))), Global => null; procedure Translate (Source : in out Bounded_String; Mapping : Maps.Character_Mapping_Function) with - Post => Length (Source) = Length (Source)'Old, + Pre => Mapping /= null, + Post => Length (Source) = Length (Source'Old) + and then + (for all K in 1 .. Length (Source) => + Element (Source, K) = Mapping (Element (Source'Old, K))), Global => null; --------------------------------------- -- String Transformation Subprograms -- --------------------------------------- + -- Each of the transformation subprograms (Replace_Slice, Insert, + -- Overwrite, Delete), selector subprograms (Trim, Head, Tail), and + -- constructor functions ("*") has an effect based on its corresponding + -- subprogram in Strings.Fixed, and Replicate is based on Fixed."*". + -- In the case of a function, the corresponding fixed-length string + -- subprogram is applied to the string represented by the Bounded_String + -- parameter. To_Bounded_String is applied the result string, with Drop + -- (or Error in the case of Generic_Bounded_Length."*") determining + -- the effect when the string length exceeds Max_Length. In + -- the case of a procedure, the corresponding function in + -- Strings.Bounded.Generic_Bounded_Length is applied, with the + -- result assigned into the Source parameter. + function Replace_Slice (Source : Bounded_String; Low : Positive; @@ -541,23 +1378,127 @@ package Ada.Strings.Bounded is Pre => Low - 1 <= Length (Source) and then - (if Drop = Error - then (if High >= Low - then Low - 1 - <= Max_Length - By'Length - - Natural'Max (Length (Source) - High, 0) - else Length (Source) <= Max_Length - By'Length)), + (if Drop = Error + then (if High >= Low + then Low - 1 + <= Max_Length - By'Length + - Integer'Max (Length (Source) - High, 0) + else Length (Source) <= Max_Length - By'Length)), Contract_Cases => - (High >= Low => - Length (Replace_Slice'Result) - = Natural'Min - (Max_Length, - Low - 1 + By'Length + Natural'Max (Length (Source) - High, - 0)), - others => - Length (Replace_Slice'Result) - = Natural'Min (Max_Length, Length (Source) + By'Length)), - Global => null; + (Low - 1 <= Max_Length - By'Length + - Integer'Max (Length (Source) - Integer'Max (High, Low - 1), 0) + => + -- Total length is lower than Max_Length: nothing is dropped + + -- Note that if High < Low, the insertion is done before Low, + -- so in all cases the starting position of the slice of Source + -- remaining after the replaced Slice is Integer'Max (High + 1, + -- Low). + + Length (Replace_Slice'Result) = Low - 1 + By'Length + + Integer'Max (Length (Source) - Integer'Max (High, Low - 1), 0) + and then + Slice (Replace_Slice'Result, 1, Low - 1) = + Slice (Source, 1, Low - 1) + and then + Slice (Replace_Slice'Result, Low, Low - 1 + By'Length) = By + and then + (if Integer'Max (High, Low - 1) < Length (Source) then + Slice (Replace_Slice'Result, + Low + By'Length, Length (Replace_Slice'Result)) = + Slice (Source, + Integer'Max (High + 1, Low), Length (Source))), + + Low - 1 > Max_Length - By'Length + - Integer'Max (Length (Source) - Integer'Max (High, Low - 1), 0) + and then Drop = Left + => + -- Final_Slice is the length of the slice of Source remaining + -- after the replaced part. + (declare + Final_Slice : constant Natural := + Integer'Max + (Length (Source) - Integer'Max (High, Low - 1), 0); + begin + -- The result is of maximal length and ends by the last + -- Final_Slice characters of Source. + + Length (Replace_Slice'Result) = Max_Length + and then + (if Final_Slice > 0 then + Slice (Replace_Slice'Result, + Max_Length - Final_Slice + 1, Max_Length) = + Slice (Source, + Integer'Max (High + 1, Low), Length (Source))) + + -- Depending on when we reach Max_Length, either the first + -- part of Source is fully dropped and By is partly dropped, + -- or By is fully added and the first part of Source is + -- partly dropped. + + and then + (if Max_Length - Final_Slice - By'Length <= 0 then + + -- The first (possibly zero) characters of By are + -- dropped. + + (if Final_Slice < Max_Length then + Slice (Replace_Slice'Result, + 1, Max_Length - Final_Slice) = + By (By'Last - Max_Length + Final_Slice + 1 + .. By'Last)) + + else -- By is added to the result + + Slice (Replace_Slice'Result, + Max_Length - Final_Slice - By'Length + 1, + Max_Length - Final_Slice) = + By + + -- The first characters of Source (1 .. Low - 1) are + -- dropped. + + and then Slice (Replace_Slice'Result, 1, + Max_Length - Final_Slice - By'Length) = + Slice (Source, + Low - Max_Length + Final_Slice + By'Length, + Low - 1))), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first Low - + -- 1 characters of Source. + + Length (Replace_Slice'Result) = Max_Length + and then + Slice (Replace_Slice'Result, 1, Low - 1) = + Slice (Source, 1, Low - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and By is partly dropped, or By + -- is fully added and the last part of Source is partly + -- dropped. + + and then + (if Low - 1 >= Max_Length - By'Length then + + -- The last characters of By are dropped + + Slice (Replace_Slice'Result, Low, Max_Length) = + By (By'First .. Max_Length - Low + By'First) + + else -- By is fully added + + Slice (Replace_Slice'Result, Low, Low + By'Length - 1) = By + + -- Then Source starting from Integer'Max (High + 1, Low) + -- is added but the last characters are dropped. + + and then Slice (Replace_Slice'Result, + Low + By'Length, Max_Length) = + Slice (Source, Integer'Max (High + 1, Low), + Integer'Max (High + 1, Low) + + (Max_Length - Low - By'Length)))); procedure Replace_Slice (Source : in out Bounded_String; @@ -569,23 +1510,119 @@ package Ada.Strings.Bounded is Pre => Low - 1 <= Length (Source) and then - (if Drop = Error - then (if High >= Low - then Low - 1 - <= Max_Length - By'Length - - Natural'Max (Length (Source) - High, 0) - else Length (Source) <= Max_Length - By'Length)), + (if Drop = Error + then (if High >= Low + then Low - 1 + <= Max_Length - By'Length + - Natural'Max (Length (Source) - High, 0) + else Length (Source) <= Max_Length - By'Length)), Contract_Cases => - (High >= Low => - Length (Source) - = Natural'Min - (Max_Length, - Low - 1 + By'Length + Natural'Max (Length (Source)'Old - High, - 0)), - others => - Length (Source) - = Natural'Min (Max_Length, Length (Source)'Old + By'Length)), - Global => null; + (Low - 1 <= Max_Length - By'Length + - Integer'Max (Length (Source) - Integer'Max (High, Low - 1), 0) + => + -- Total length is lower than Max_Length: nothing is dropped + + -- Note that if High < Low, the insertion is done before Low, + -- so in all cases the starting position of the slice of Source + -- remaining after the replaced Slice is Integer'Max (High + 1, + -- Low). + + Length (Source) = Low - 1 + By'Length + Integer'Max + (Length (Source'Old) - Integer'Max (High, Low - 1), 0) + and then + Slice (Source, 1, Low - 1) = Slice (Source'Old, 1, Low - 1) + and then Slice (Source, Low, Low - 1 + By'Length) = By + and then + (if Integer'Max (High, Low - 1) < Length (Source'Old) then + Slice (Source, Low + By'Length, Length (Source)) = + Slice (Source'Old, + Integer'Max (High + 1, Low), Length (Source'Old))), + + Low - 1 > Max_Length - By'Length + - Integer'Max (Length (Source) - Integer'Max (High, Low - 1), 0) + and then Drop = Left + => + -- Final_Slice is the length of the slice of Source remaining + -- after the replaced part. + (declare + Final_Slice : constant Integer := + Integer'Max (0, + Length (Source'Old) - Integer'Max (High, Low - 1)); + begin + -- The result is of maximal length and ends by the last + -- Final_Slice characters of Source. + + Length (Source) = Max_Length + and then + (if Final_Slice > 0 then + Slice (Source, + Max_Length - Final_Slice + 1, Max_Length) = + Slice (Source'Old, + Integer'Max (High + 1, Low), Length (Source'Old))) + + -- Depending on when we reach Max_Length, either the first + -- part of Source is fully dropped and By is partly dropped, + -- or By is fully added and the first part of Source is + -- partly dropped. + + and then + (if Max_Length - Final_Slice - By'Length <= 0 then + + -- The first characters of By are dropped + + (if Final_Slice < Max_Length then + Slice (Source, 1, Max_Length - Final_Slice) = + By (By'Last - Max_Length + Final_Slice + 1 + .. By'Last)) + + else -- By is added to the result + + Slice (Source, + Max_Length - Final_Slice - By'Length + 1, + Max_Length - Final_Slice) = By + + -- The first characters of Source (1 .. Low - 1) are + -- dropped. + + and then Slice (Source, 1, + Max_Length - Final_Slice - By'Length) = + Slice (Source'Old, + Low - Max_Length + Final_Slice + By'Length, + Low - 1))), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first Low - + -- 1 characters of Source. + + Length (Source) = Max_Length + and then + Slice (Source, 1, Low - 1) = Slice (Source'Old, 1, Low - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and By is partly dropped, or By + -- is fully added and the last part of Source is partly + -- dropped. + + and then + (if Low - 1 >= Max_Length - By'Length then + + -- The last characters of By are dropped + + Slice (Source, Low, Max_Length) = + By (By'First .. Max_Length - Low + By'First) + + else -- By is fully added + + Slice (Source, Low, Low + By'Length - 1) = By + + -- Then Source starting from Natural'Max (High + 1, Low) + -- is added but the last characters are dropped. + + and then Slice (Source, Low + By'Length, Max_Length) = + Slice (Source'Old, Integer'Max (High + 1, Low), + Integer'Max (High + 1, Low) + + (Max_Length - Low - By'Length)))); function Insert (Source : Bounded_String; @@ -593,14 +1630,113 @@ package Ada.Strings.Bounded is New_Item : String; Drop : Truncation := Error) return Bounded_String with - Pre => + Pre => Before - 1 <= Length (Source) and then (if New_Item'Length > Max_Length - Length (Source) then Drop /= Error), - Post => - Length (Insert'Result) - = Natural'Min (Max_Length, Length (Source) + New_Item'Length), - Global => null; + Contract_Cases => + (Length (Source) <= Max_Length - New_Item'Length + => + -- Total length is lower than Max_Length: nothing is dropped + + Length (Insert'Result) = Length (Source) + New_Item'Length + and then + Slice (Insert'Result, 1, Before - 1) = + Slice (Source, 1, Before - 1) + and then + Slice (Insert'Result, Before, Before - 1 + New_Item'Length) = + New_Item + and then + (if Before <= Length (Source) then + Slice (Insert'Result, + Before + New_Item'Length, Length (Insert'Result)) = + Slice (Source, Before, Length (Source))), + + Length (Source) > Max_Length - New_Item'Length and then Drop = Left + => + -- The result is of maximal length and ends by the last + -- characters of Source. + + Length (Insert'Result) = Max_Length + and then + (if Before <= Length (Source) then + Slice (Insert'Result, + Max_Length - Length (Source) + Before, Max_Length) = + Slice (Source, Before, Length (Source))) + + -- Depending on when we reach Max_Length, either the first part + -- of Source is fully dropped and New_Item is partly dropped, + -- or New_Item is fully added and the first part of Source is + -- partly dropped. + + and then + (if Max_Length - Length (Source) - 1 + Before + < New_Item'Length + then + -- The first characters of New_Item are dropped + + (if Length (Source) - Before + 1 < Max_Length then + Slice (Insert'Result, + 1, Max_Length - Length (Source) - 1 + Before) = + New_Item + (New_Item'Last - Max_Length + Length (Source) + - Before + 2 + .. New_Item'Last)) + + else -- New_Item is added to the result + + Slice (Insert'Result, + Max_Length - Length (Source) - New_Item'Length + Before, + Max_Length - Length (Source) - 1 + Before) = New_Item + + -- The first characters of Source (1 .. Before - 1) are + -- dropped. + + and then Slice (Insert'Result, + 1, Max_Length - Length (Source) - New_Item'Length + - 1 + Before) = + Slice (Source, + Length (Source) - Max_Length + New_Item'Length + + 1, + Before - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Length (Insert'Result) = Max_Length + and then + Slice (Insert'Result, 1, Before - 1) = + Slice (Source, 1, Before - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and New_Item is partly dropped, + -- or New_Item is fully added and the last part of Source is + -- partly dropped. + + and then + (if Before - 1 >= Max_Length - New_Item'Length then + + -- The last characters of New_Item are dropped + + Slice (Insert'Result, Before, Max_Length) = + New_Item (New_Item'First + .. Max_Length - Before + New_Item'First) + + else -- New_Item is fully added + + Slice (Insert'Result, + Before, Before + New_Item'Length - 1) = + New_Item + + -- Then Source starting from Before is added but the + -- last characters are dropped. + + and then Slice (Insert'Result, + Before + New_Item'Length, Max_Length) = + Slice (Source, + Before, Max_Length - New_Item'Length))); procedure Insert (Source : in out Bounded_String; @@ -608,14 +1744,112 @@ package Ada.Strings.Bounded is New_Item : String; Drop : Truncation := Error) with - Pre => + Pre => Before - 1 <= Length (Source) and then (if New_Item'Length > Max_Length - Length (Source) then Drop /= Error), - Post => - Length (Source) - = Natural'Min (Max_Length, Length (Source)'Old + New_Item'Length), - Global => null; + Contract_Cases => + (Length (Source) <= Max_Length - New_Item'Length + => + -- Total length is lower than Max_Length: nothing is dropped + + Length (Source) = Length (Source'Old) + New_Item'Length + and then + Slice (Source, 1, Before - 1) = + Slice (Source'Old, 1, Before - 1) + and then + Slice (Source, Before, Before - 1 + New_Item'Length) = + New_Item + and then + (if Before <= Length (Source'Old) then + Slice (Source, Before + New_Item'Length, Length (Source)) = + Slice (Source'Old, Before, Length (Source'Old))), + + Length (Source) > Max_Length - New_Item'Length and then Drop = Left + => + -- The result is of maximal length and ends by the last + -- characters of Source. + + Length (Source) = Max_Length + and then + (if Before <= Length (Source'Old) then + Slice (Source, + Max_Length - Length (Source'Old) + Before, Max_Length) = + Slice (Source'Old, Before, Length (Source'Old))) + + -- Depending on when we reach Max_Length, either the first part + -- of Source is fully dropped and New_Item is partly dropped, + -- or New_Item is fully added and the first part of Source is + -- partly dropped. + + and then + (if Max_Length - Length (Source'Old) - 1 + Before + < New_Item'Length + then + -- The first characters of New_Item are dropped + + (if Length (Source'Old) - Before + 1 < Max_Length then + Slice (Source, + 1, Max_Length - Length (Source'Old) - 1 + Before) = + New_Item + (New_Item'Last - Max_Length + Length (Source'Old) + - Before + 2 + .. New_Item'Last)) + + else -- New_Item is added to the result + + Slice (Source, + Max_Length - Length (Source'Old) - New_Item'Length + + Before, + Max_Length - Length (Source'Old) - 1 + Before) = New_Item + + -- The first characters of Source (1 .. Before - 1) are + -- dropped. + + and then Slice (Source, 1, + Max_Length - Length (Source'Old) - New_Item'Length + - 1 + Before) = + Slice (Source'Old, + Length (Source'Old) + - Max_Length + New_Item'Length + 1, + Before - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Length (Source) = Max_Length + and then + Slice (Source, 1, Before - 1) = + Slice (Source'Old, 1, Before - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and New_Item is partly dropped, + -- or New_Item is fully added and the last part of Source is + -- partly dropped. + + and then + (if Before - 1 >= Max_Length - New_Item'Length then + + -- The last characters of New_Item are dropped + + Slice (Source, Before, Max_Length) = + New_Item (New_Item'First + .. Max_Length - Before + New_Item'First) + + else -- New_Item is fully added + + Slice (Source, Before, Before + New_Item'Length - 1) = + New_Item + + -- Then Source starting from Before is added but the + -- last characters are dropped. + + and then + Slice (Source, Before + New_Item'Length, Max_Length) = + Slice (Source'Old, + Before, Max_Length - New_Item'Length))); function Overwrite (Source : Bounded_String; @@ -623,16 +1857,85 @@ package Ada.Strings.Bounded is New_Item : String; Drop : Truncation := Error) return Bounded_String with - Pre => + Pre => Position - 1 <= Length (Source) and then (if New_Item'Length > Max_Length - (Position - 1) then Drop /= Error), - Post => - Length (Overwrite'Result) - = Natural'Max - (Length (Source), - Natural'Min (Max_Length, Position - 1 + New_Item'Length)), - Global => null; + Contract_Cases => + (Position - 1 <= Max_Length - New_Item'Length + => + -- The length is unchanged, unless New_Item overwrites further + -- than the end of Source. In this contract case, we suppose + -- New_Item doesn't overwrite further than Max_Length. + + Length (Overwrite'Result) = + Integer'Max (Length (Source), Position - 1 + New_Item'Length) + and then + Slice (Overwrite'Result, 1, Position - 1) = + Slice (Source, 1, Position - 1) + and then Slice (Overwrite'Result, + Position, Position - 1 + New_Item'Length) = + New_Item + and then + (if Position - 1 + New_Item'Length < Length (Source) then + + -- There are some unchanged characters of Source remaining + -- after New_Item. + + Slice (Overwrite'Result, + Position + New_Item'Length, Length (Source)) = + Slice (Source, + Position + New_Item'Length, Length (Source))), + + Position - 1 > Max_Length - New_Item'Length and then Drop = Left + => + Length (Overwrite'Result) = Max_Length + + -- If a part of the result has to be dropped, it means New_Item + -- is overwriting further than the end of Source. Thus the + -- result is necessarily ending by New_Item. However, we don't + -- know whether New_Item covers all Max_Length characters or + -- some characters of Source are remaining at the left. + + and then + (if New_Item'Length > Max_Length then + + -- New_Item covers all Max_Length characters + + To_String (Overwrite'Result) = + New_Item + (New_Item'Last - Max_Length + 1 .. New_Item'Last) + else + -- New_Item fully appears at the end + + Slice (Overwrite'Result, + Max_Length - New_Item'Length + 1, Max_Length) = + New_Item + + -- The left of Source is cut + + and then + Slice (Overwrite'Result, + 1, Max_Length - New_Item'Length) = + Slice (Source, + Position - Max_Length + New_Item'Length, + Position - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Length (Overwrite'Result) = Max_Length + and then + Slice (Overwrite'Result, 1, Position - 1) = + Slice (Source, 1, Position - 1) + + -- Then New_Item is written until Max_Length + + and then Slice (Overwrite'Result, Position, Max_Length) = + New_Item + (New_Item'First .. Max_Length - Position + New_Item'First)); procedure Overwrite (Source : in out Bounded_String; @@ -640,16 +1943,84 @@ package Ada.Strings.Bounded is New_Item : String; Drop : Truncation := Error) with - Pre => + Pre => Position - 1 <= Length (Source) and then (if New_Item'Length > Max_Length - (Position - 1) then Drop /= Error), - Post => - Length (Source) - = Natural'Max - (Length (Source)'Old, - Natural'Min (Max_Length, Position - 1 + New_Item'Length)), - Global => null; + Contract_Cases => + (Position - 1 <= Max_Length - New_Item'Length + => + -- The length of Source is unchanged, unless New_Item overwrites + -- further than the end of Source. In this contract case, we + -- suppose New_Item doesn't overwrite further than Max_Length. + + Length (Source) = Integer'Max + (Length (Source'Old), Position - 1 + New_Item'Length) + and then + Slice (Source, 1, Position - 1) = + Slice (Source'Old, 1, Position - 1) + and then Slice (Source, + Position, Position - 1 + New_Item'Length) = + New_Item + and then + (if Position - 1 + New_Item'Length < Length (Source'Old) then + + -- There are some unchanged characters of Source remaining + -- after New_Item. + + Slice (Source, + Position + New_Item'Length, Length (Source'Old)) = + Slice (Source'Old, + Position + New_Item'Length, Length (Source'Old))), + + Position - 1 > Max_Length - New_Item'Length and then Drop = Left + => + Length (Source) = Max_Length + + -- If a part of the result has to be dropped, it means New_Item + -- is overwriting further than the end of Source. Thus the + -- result is necessarily ending by New_Item. However, we don't + -- know whether New_Item covers all Max_Length characters or + -- some characters of Source are remaining at the left. + + and then + (if New_Item'Length > Max_Length then + + -- New_Item covers all Max_Length characters + + To_String (Source) = + New_Item + (New_Item'Last - Max_Length + 1 .. New_Item'Last) + else + -- New_Item fully appears at the end + + Slice (Source, + Max_Length - New_Item'Length + 1, Max_Length) = + New_Item + + -- The left of Source is cut + + and then + Slice (Source, 1, Max_Length - New_Item'Length) = + Slice (Source'Old, + Position - Max_Length + New_Item'Length, + Position - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Length (Source) = Max_Length + and then + Slice (Source, 1, Position - 1) = + Slice (Source'Old, 1, Position - 1) + + -- New_Item is written until Max_Length + + and then Slice (Source, Position, Max_Length) = + New_Item + (New_Item'First .. Max_Length - Position + New_Item'First)); function Delete (Source : Bounded_String; @@ -657,13 +2028,20 @@ package Ada.Strings.Bounded is Through : Natural) return Bounded_String with Pre => - (if Through <= From then From - 1 <= Length (Source)), + (if Through >= From then From - 1 <= Length (Source)), Contract_Cases => (Through >= From => - Length (Delete'Result) = Length (Source) - (Through - From + 1), + Length (Delete'Result) = + From - 1 + Natural'Max (Length (Source) - Through, 0) + and then + Slice (Delete'Result, 1, From - 1) = + Slice (Source, 1, From - 1) + and then + (if Through < Length (Source) then + Slice (Delete'Result, From, Length (Delete'Result)) = + Slice (Source, Through + 1, Length (Source))), others => - Length (Delete'Result) = Length (Source)), - + Delete'Result = Source), Global => null; procedure Delete @@ -672,12 +2050,19 @@ package Ada.Strings.Bounded is Through : Natural) with Pre => - (if Through <= From then From - 1 <= Length (Source)), + (if Through >= From then From - 1 <= Length (Source)), Contract_Cases => (Through >= From => - Length (Source) = Length (Source)'Old - (Through - From + 1), + Length (Source) = + From - 1 + Natural'Max (Length (Source'Old) - Through, 0) + and then + Slice (Source, 1, From - 1) = Slice (Source'Old, 1, From - 1) + and then + (if Through < Length (Source) then + Slice (Source, From, Length (Source)) = + Slice (Source'Old, Through + 1, Length (Source'Old))), others => - Length (Source) = Length (Source)'Old), + Source = Source'Old), Global => null; --------------------------------- @@ -688,31 +2073,111 @@ package Ada.Strings.Bounded is (Source : Bounded_String; Side : Trim_End) return Bounded_String with - Post => Length (Trim'Result) <= Length (Source), - Global => null; + Contract_Cases => + -- If all characters in Source are Space, the returned string is + -- empty. + + ((for all C of To_String (Source) => C = ' ') + => + Length (Trim'Result) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + (if Side = Right then 1 + else Index_Non_Blank (Source, Forward)); + High : constant Positive := + (if Side = Left then Length (Source) + else Index_Non_Blank (Source, Backward)); + begin + To_String (Trim'Result) = Slice (Source, Low, High))), + Global => null; procedure Trim (Source : in out Bounded_String; Side : Trim_End) with - Post => Length (Source) <= Length (Source)'Old, - Global => null; + Contract_Cases => + -- If all characters in Source are Space, the returned string is + -- empty. + + ((for all C of To_String (Source) => C = ' ') + => + Length (Source) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + (if Side = Right then 1 + else Index_Non_Blank (Source'Old, Forward)); + High : constant Positive := + (if Side = Left then Length (Source'Old) + else Index_Non_Blank (Source'Old, Backward)); + begin + To_String (Source) = Slice (Source'Old, Low, High))), + Global => null; function Trim (Source : Bounded_String; Left : Maps.Character_Set; Right : Maps.Character_Set) return Bounded_String with - Post => Length (Trim'Result) <= Length (Source), - Global => null; + Contract_Cases => + -- If all characters in Source are contained in one of the sets Left + -- or Right, then the returned string is empty. + + ((for all C of To_String (Source) => Maps.Is_In (C, Left)) + or else + (for all C of To_String (Source) => Maps.Is_In (C, Right)) + => + Length (Trim'Result) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + Index (Source, Left, Outside, Forward); + High : constant Positive := + Index (Source, Right, Outside, Backward); + begin + To_String (Trim'Result) = Slice (Source, Low, High))), + Global => null; procedure Trim (Source : in out Bounded_String; Left : Maps.Character_Set; Right : Maps.Character_Set) with - Post => Length (Source) <= Length (Source)'Old, - Global => null; + Contract_Cases => + -- If all characters in Source are contained in one of the sets Left + -- or Right, then the returned string is empty. + + ((for all C of To_String (Source) => Maps.Is_In (C, Left)) + or else + (for all C of To_String (Source) => Maps.Is_In (C, Right)) + => + Length (Source) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + Index (Source'Old, Left, Outside, Forward); + High : constant Positive := + Index (Source'Old, Right, Outside, Backward); + begin + To_String (Source) = Slice (Source'Old, Low, High))), + Global => null; function Head (Source : Bounded_String; @@ -720,9 +2185,54 @@ package Ada.Strings.Bounded is Pad : Character := Space; Drop : Truncation := Error) return Bounded_String with - Pre => (if Count > Max_Length then Drop /= Error), - Post => Length (Head'Result) = Natural'Min (Max_Length, Count), - Global => null; + Pre => (if Count > Max_Length then Drop /= Error), + Contract_Cases => + (Count <= Length (Source) + => + -- Source is cut + + To_String (Head'Result) = Slice (Source, 1, Count), + + Count > Length (Source) and then Count <= Max_Length + => + -- Source is followed by Pad characters + + Length (Head'Result) = Count + and then + Slice (Head'Result, 1, Length (Source)) = To_String (Source) + and then + Slice (Head'Result, Length (Source) + 1, Count) = + (1 .. Count - Length (Source) => Pad), + + Count > Max_Length and then Drop = Right + => + -- Source is followed by Pad characters + + Length (Head'Result) = Max_Length + and then + Slice (Head'Result, 1, Length (Source)) = To_String (Source) + and then + Slice (Head'Result, Length (Source) + 1, Max_Length) = + (1 .. Max_Length - Length (Source) => Pad), + + Count - Length (Source) > Max_Length and then Drop = Left + => + -- Source is fully dropped at the left + + To_String (Head'Result) = (1 .. Max_Length => Pad), + + others + => + -- Source is partly dropped at the left + + Length (Head'Result) = Max_Length + and then + Slice (Head'Result, 1, Max_Length - Count + Length (Source)) = + Slice (Source, Count - Max_Length + 1, Length (Source)) + and then + Slice (Head'Result, + Max_Length - Count + Length (Source) + 1, Max_Length) = + (1 .. Count - Length (Source) => Pad)); procedure Head (Source : in out Bounded_String; @@ -730,9 +2240,57 @@ package Ada.Strings.Bounded is Pad : Character := Space; Drop : Truncation := Error) with - Pre => (if Count > Max_Length then Drop /= Error), - Post => Length (Source) = Natural'Min (Max_Length, Count), - Global => null; + Pre => (if Count > Max_Length then Drop /= Error), + Contract_Cases => + (Count <= Length (Source) + => + -- Source is cut + + To_String (Source) = Slice (Source'Old, 1, Count), + + Count > Length (Source) and then Count <= Max_Length + => + -- Source is followed by Pad characters + + Length (Source) = Count + and then + Slice (Source, 1, Length (Source'Old)) = + To_String (Source'Old) + and then + Slice (Source, Length (Source'Old) + 1, Count) = + (1 .. Count - Length (Source'Old) => Pad), + + Count > Max_Length and then Drop = Right + => + -- Source is followed by Pad characters + + Length (Source) = Max_Length + and then + Slice (Source, 1, Length (Source'Old)) = + To_String (Source'Old) + and then + Slice (Source, Length (Source'Old) + 1, Max_Length) = + (1 .. Max_Length - Length (Source'Old) => Pad), + + Count - Length (Source) > Max_Length and then Drop = Left + => + -- Source is fully dropped on the left + + To_String (Source) = (1 .. Max_Length => Pad), + + others + => + -- Source is partly dropped on the left + + Length (Source) = Max_Length + and then + Slice (Source, 1, Max_Length - Count + Length (Source'Old)) = + Slice (Source'Old, + Count - Max_Length + 1, Length (Source'Old)) + and then + Slice (Source, + Max_Length - Count + Length (Source'Old) + 1, Max_Length) = + (1 .. Count - Length (Source'Old) => Pad)); function Tail (Source : Bounded_String; @@ -740,9 +2298,60 @@ package Ada.Strings.Bounded is Pad : Character := Space; Drop : Truncation := Error) return Bounded_String with - Pre => (if Count > Max_Length then Drop /= Error), - Post => Length (Tail'Result) = Natural'Min (Max_Length, Count), - Global => null; + Pre => (if Count > Max_Length then Drop /= Error), + Contract_Cases => + (Count < Length (Source) + => + -- Source is cut + + (if Count > 0 then + To_String (Tail'Result) = + Slice (Source, Length (Source) - Count + 1, Length (Source)) + else Length (Tail'Result) = 0), + + Count >= Length (Source) and then Count < Max_Length + => + -- Source is preceded by Pad characters + + Length (Tail'Result) = Count + and then + Slice (Tail'Result, 1, Count - Length (Source)) = + (1 .. Count - Length (Source) => Pad) + and then + Slice (Tail'Result, Count - Length (Source) + 1, Count) = + To_String (Source), + + Count >= Max_Length and then Drop = Left + => + -- Source is preceded by Pad characters + + Length (Tail'Result) = Max_Length + and then + Slice (Tail'Result, 1, Max_Length - Length (Source)) = + (1 .. Max_Length - Length (Source) => Pad) + and then + (if Length (Source) > 0 then + Slice (Tail'Result, + Max_Length - Length (Source) + 1, Max_Length) = + To_String (Source)), + + Count - Length (Source) >= Max_Length and then Drop /= Left + => + -- Source is fully dropped on the right + + To_String (Tail'Result) = (1 .. Max_Length => Pad), + + others + => + -- Source is partly dropped on the right + + Length (Tail'Result) = Max_Length + and then + Slice (Tail'Result, 1, Count - Length (Source)) = + (1 .. Count - Length (Source) => Pad) + and then + Slice (Tail'Result, Count - Length (Source) + 1, Max_Length) = + Slice (Source, 1, Max_Length - Count + Length (Source))); procedure Tail (Source : in out Bounded_String; @@ -750,9 +2359,62 @@ package Ada.Strings.Bounded is Pad : Character := Space; Drop : Truncation := Error) with - Pre => (if Count > Max_Length then Drop /= Error), - Post => Length (Source) = Natural'Min (Max_Length, Count), - Global => null; + Pre => (if Count > Max_Length then Drop /= Error), + Contract_Cases => + (Count < Length (Source) + => + -- Source is cut + + (if Count > 0 then + To_String (Source) = + Slice (Source'Old, + Length (Source'Old) - Count + 1, Length (Source'Old)) + else Length (Source) = 0), + + Count >= Length (Source) and then Count < Max_Length + => + -- Source is preceded by Pad characters + + Length (Source) = Count + and then + Slice (Source, 1, Count - Length (Source'Old)) = + (1 .. Count - Length (Source'Old) => Pad) + and then + Slice (Source, Count - Length (Source'Old) + 1, Count) = + To_String (Source'Old), + + Count >= Max_Length and then Drop = Left + => + -- Source is preceded by Pad characters + + Length (Source) = Max_Length + and then + Slice (Source, 1, Max_Length - Length (Source'Old)) = + (1 .. Max_Length - Length (Source'Old) => Pad) + and then + (if Length (Source'Old) > 0 then + Slice (Source, + Max_Length - Length (Source'Old) + 1, Max_Length) = + To_String (Source'Old)), + + Count - Length (Source) >= Max_Length and then Drop /= Left + => + -- Source is fully dropped at the right + + To_String (Source) = (1 .. Max_Length => Pad), + + others + => + -- Source is partly dropped at the right + + Length (Source) = Max_Length + and then + Slice (Source, 1, Count - Length (Source'Old)) = + (1 .. Count - Length (Source'Old) => Pad) + and then + Slice (Source, Count - Length (Source'Old) + 1, Max_Length) = + Slice (Source'Old, + 1, Max_Length - Count + Length (Source'Old))); ------------------------------------ -- String Constructor Subprograms -- @@ -762,64 +2424,113 @@ package Ada.Strings.Bounded is (Left : Natural; Right : Character) return Bounded_String with - Pre => Left <= Max_Length, - Post => Length ("*"'Result) = Left, - Global => null; + Pre => Left <= Max_Length, + Post => To_String ("*"'Result) = (1 .. Left => Right); function "*" (Left : Natural; Right : String) return Bounded_String with - Pre => (if Left /= 0 then Right'Length <= Max_Length / Left), - Post => Length ("*"'Result) = Left * Right'Length, - Global => null; + Pre => (if Left /= 0 then Right'Length <= Max_Length / Left), + Post => + Length ("*"'Result) = Left * Right'Length + and then + (if Right'Length > 0 then + (for all K in 1 .. Left * Right'Length => + Element ("*"'Result, K) = + Right (Right'First + (K - 1) mod Right'Length))); function "*" (Left : Natural; Right : Bounded_String) return Bounded_String with - Pre => (if Left /= 0 then Length (Right) <= Max_Length / Left), - Post => Length ("*"'Result) = Left * Length (Right), - Global => null; + Pre => (if Left /= 0 then Length (Right) <= Max_Length / Left), + Post => + Length ("*"'Result) = Left * Length (Right) + and then + (if Length (Right) > 0 then + (for all K in 1 .. Left * Length (Right) => + Element ("*"'Result, K) = + Element (Right, 1 + (K - 1) mod Length (Right)))); function Replicate (Count : Natural; Item : Character; Drop : Truncation := Error) return Bounded_String with - Pre => (if Count > Max_Length then Drop /= Error), - Post => - Length (Replicate'Result) - = Natural'Min (Max_Length, Count), - Global => null; + Pre => (if Count > Max_Length then Drop /= Error), + Post => + To_String (Replicate'Result) = + (1 .. Natural'Min (Max_Length, Count) => Item); function Replicate (Count : Natural; Item : String; Drop : Truncation := Error) return Bounded_String with - Pre => - (if Item'Length /= 0 - and then Count > Max_Length / Item'Length + Pre => + (if Count /= 0 and then Item'Length > Max_Length / Count then Drop /= Error), - Post => - Length (Replicate'Result) - = Natural'Min (Max_Length, Count * Item'Length), - Global => null; + Contract_Cases => + (Count = 0 or else Item'Length <= Max_Length / Count + => + Length (Replicate'Result) = Count * Item'Length + and then + (if Item'Length > 0 then + (for all K in 1 .. Count * Item'Length => + Element (Replicate'Result, K) = + Item (Item'First + (K - 1) mod Item'Length))), + Count /= 0 + and then Item'Length > Max_Length / Count + and then Drop = Right + => + Length (Replicate'Result) = Max_Length + and then + (for all K in 1 .. Max_Length => + Element (Replicate'Result, K) = + Item (Item'First + (K - 1) mod Item'Length)), + others -- Drop = Left + => + Length (Replicate'Result) = Max_Length + and then + (for all K in 1 .. Max_Length => + Element (Replicate'Result, K) = + Item (Item'Last - (Max_Length - K) mod Item'Length))); function Replicate (Count : Natural; Item : Bounded_String; Drop : Truncation := Error) return Bounded_String with - Pre => - (if Length (Item) /= 0 - and then Count > Max_Length / Length (Item) + Pre => + (if Count /= 0 and then Length (Item) > Max_Length / Count then Drop /= Error), - Post => - Length (Replicate'Result) - = Natural'Min (Max_Length, Count * Length (Item)), - Global => null; + Contract_Cases => + ((if Count /= 0 then Length (Item) <= Max_Length / Count) + => + Length (Replicate'Result) = Count * Length (Item) + and then + (if Length (Item) > 0 then + (for all K in 1 .. Count * Length (Item) => + Element (Replicate'Result, K) = + Element (Item, 1 + (K - 1) mod Length (Item)))), + Count /= 0 + and then Length (Item) > Max_Length / Count + and then Drop = Right + => + Length (Replicate'Result) = Max_Length + and then + (for all K in 1 .. Max_Length => + Element (Replicate'Result, K) = + Element (Item, 1 + (K - 1) mod Length (Item))), + others -- Drop = Left + => + Length (Replicate'Result) = Max_Length + and then + (for all K in 1 .. Max_Length => + Element (Replicate'Result, K) = + Element (Item, + Length (Item) - (Max_Length - K) mod Length (Item)))); private -- Most of the implementation is in the separate non generic package @@ -843,7 +2554,8 @@ package Ada.Strings.Bounded is -- the generic instantiation is compatible with the Super_String -- type declared in the Superbounded package. - function From_String (Source : String) return Bounded_String; + function From_String (Source : String) return Bounded_String + with Pre => Source'Length <= Max_Length; -- Private routine used only by Stream_Convert pragma Stream_Convert (Bounded_String, From_String, To_String); diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index 00967c4..31dea6c 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -214,7 +214,8 @@ package body Ada.Strings.Fixed with SPARK_Mode is -- Lemma_Split -- ----------------- - procedure Lemma_Split (Result : String) is + procedure Lemma_Split (Result : String) + is begin for K in Ptr + 1 .. Ptr + Right'Length loop Lemma_Mod (K - 1); @@ -307,7 +308,8 @@ package body Ada.Strings.Fixed with SPARK_Mode is From : Positive; Through : Natural; Justify : Alignment := Left; - Pad : Character := Space) with SPARK_Mode => Off is + Pad : Character := Space) + is begin Move (Source => Delete (Source, From, Through), Target => Source, @@ -403,7 +405,8 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Before : Positive; New_Item : String; - Drop : Truncation := Error) with SPARK_Mode => Off is + Drop : Truncation := Error) + is begin Move (Source => Insert (Source, Before, New_Item), Target => Source, @@ -419,7 +422,8 @@ package body Ada.Strings.Fixed with SPARK_Mode is Target : out String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space) with SPARK_Mode => Off + Pad : Character := Space) + with SPARK_Mode => Off is Sfirst : constant Integer := Source'First; Slast : constant Integer := Source'Last; @@ -571,7 +575,8 @@ package body Ada.Strings.Fixed with SPARK_Mode is (Source : in out String; Position : Positive; New_Item : String; - Drop : Truncation := Right) with SPARK_Mode => Off is + Drop : Truncation := Right) + is begin Move (Source => Overwrite (Source, Position, New_Item), Target => Source, @@ -648,7 +653,8 @@ package body Ada.Strings.Fixed with SPARK_Mode is By : String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space) with SPARK_Mode => Off is + Pad : Character := Space) + is begin Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); end Replace_Slice; @@ -865,7 +871,7 @@ package body Ada.Strings.Fixed with SPARK_Mode is High, Low : Integer; begin - Low := Index (Source, Set => Left, Test => Outside, Going => Forward); + Low := Index (Source, Set => Left, Test => Outside, Going => Forward); -- Case where source comprises only characters in Left diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads index 1a5ee94..1d9fd1b 100644 --- a/gcc/ada/libgnat/a-strfix.ads +++ b/gcc/ada/libgnat/a-strfix.ads @@ -382,7 +382,7 @@ package Ada.Strings.Fixed with SPARK_Mode is => Index'Result = 0, - -- Otherwise, a index in the range of Source is returned + -- Otherwise, an index in the range of Source is returned others => @@ -392,7 +392,7 @@ package Ada.Strings.Fixed with SPARK_Mode is Index'Result in Source'Range -- The character at the returned index satisfies the property - -- Test on Set + -- Test on Set. and then (Test = Inside) @@ -433,7 +433,7 @@ package Ada.Strings.Fixed with SPARK_Mode is => Index'Result = 0, - -- Otherwise, a index in the considered range of Source is returned + -- Otherwise, an index in the considered range of Source is returned others => @@ -904,7 +904,15 @@ package Ada.Strings.Fixed with SPARK_Mode is Justify : Alignment := Left; Pad : Character := Space) with - Pre => Low - 1 <= Source'Last, + Pre => + Low - 1 <= Source'Last + and then High >= Source'First - 1 + and then (if High >= Low + then Natural'Max (0, Low - Source'First) + <= Natural'Last + - By'Length + - Natural'Max (Source'Last - High, 0) + else Source'Length <= Natural'Last - By'Length), -- Incomplete contract @@ -966,7 +974,9 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Error) with - Pre => Before - 1 in Source'First - 1 .. Source'Last, + Pre => + Before - 1 in Source'First - 1 .. Source'Last + and then Source'Length <= Natural'Last - New_Item'Length, -- Incomplete contract @@ -1033,7 +1043,11 @@ package Ada.Strings.Fixed with SPARK_Mode is New_Item : String; Drop : Truncation := Right) with - Pre => Position - 1 in Source'First - 1 .. Source'Last, + Pre => + Position - 1 in Source'First - 1 .. Source'Last + and then + (if Position - Source'First >= Source'Length - New_Item'Length + then Position - Source'First <= Natural'Last - New_Item'Length), -- Incomplete contract @@ -1133,31 +1147,15 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Otherwise, the returned string is a slice of Source else - (for some Low in Source'Range => - (for some High in Source'Range => - - -- Trim returns the slice of Source between Low and High - - Trim'Result = Source (Low .. High) - - -- Values of Low and High and the characters at their - -- position depend on Side. - - and then - (if Side = Left then High = Source'Last - else Source (High) /= ' ') - and then - (if Side = Right then Low = Source'First - else Source (Low) /= ' ') - - -- All characters outside range Low .. High are - -- Space characters. - - and then - (for all J in Source'Range => - (if J < Low then Source (J) = ' ') - and then - (if J > High then Source (J) = ' '))))), + (declare + Low : constant Positive := + (if Side = Right then Source'First + else Index_Non_Blank (Source, Forward)); + High : constant Positive := + (if Side = Left then Source'Last + else Index_Non_Blank (Source, Backward)); + begin + Trim'Result = Source (Low .. High))), Global => null; -- Returns the string obtained by removing from Source all leading Space -- characters (if Side = Left), all trailing Space characters (if @@ -1203,30 +1201,13 @@ package Ada.Strings.Fixed with SPARK_Mode is -- Otherwise, the returned string is a slice of Source else - (for some Low in Source'Range => - (for some High in Source'Range => - - -- Trim returns the slice of Source between Low and High - - Trim'Result = Source (Low .. High) - - -- Characters at the bounds of the returned string are - -- not contained in Left or Right. - - and then not Ada.Strings.Maps.Is_In (Source (Low), Left) - and then not Ada.Strings.Maps.Is_In (Source (High), Right) - - -- All characters before Low are contained in Left. - -- All characters after High are contained in Right. - - and then - (for all K in Source'Range => - (if K < Low - then - Ada.Strings.Maps.Is_In (Source (K), Left)) - and then - (if K > High then - Ada.Strings.Maps.Is_In (Source (K), Right)))))), + (declare + Low : constant Positive := + Index (Source, Left, Outside, Forward); + High : constant Positive := + Index (Source, Right, Outside, Backward); + begin + Trim'Result = Source (Low .. High))), Global => null; -- Returns the string obtained by removing from Source all leading -- characters in Left and all trailing characters in Right. diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index 8ad9f12..c87f4e5 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -35,7 +35,17 @@ -- is bit-by-bit or character-by-character and therefore rather slow. -- Generally for character sets we favor the full 32-byte representation. -package body Ada.Strings.Maps is +-- Assertions, ghost code and loop invariants in this unit are meant for +-- analysis only, not for run-time checking, as it would be too costly +-- otherwise. This is enforced by setting the assertion policy to Ignore. + +pragma Assertion_Policy (Assert => Ignore, + Ghost => Ignore, + Loop_Invariant => Ignore); + +package body Ada.Strings.Maps + with SPARK_Mode +is --------- -- "-" -- @@ -102,9 +112,7 @@ package body Ada.Strings.Maps is (Element : Character; Set : Character_Set) return Boolean is - begin - return Set (Element); - end Is_In; + (Set (Element)); --------------- -- Is_Subset -- @@ -122,18 +130,37 @@ package body Ada.Strings.Maps is -- To_Domain -- --------------- - function To_Domain (Map : Character_Mapping) return Character_Sequence - is - Result : String (1 .. Map'Length); + function To_Domain (Map : Character_Mapping) return Character_Sequence is + Result : String (1 .. Map'Length) with Relaxed_Initialization; J : Natural; + type Character_Index is array (Character) of Natural with Ghost; + Indexes : Character_Index := (others => 0) with Ghost; + begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := C; + Indexes (C) := J; end if; + + pragma Loop_Invariant (if Map = Identity then J = 0); + pragma Loop_Invariant (J <= Character'Pos (C) + 1); + pragma Loop_Invariant (Result (1 .. J)'Initialized); + pragma Loop_Invariant (for all K in 1 .. J => Result (K) <= C); + pragma Loop_Invariant + (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. J))); + pragma Loop_Invariant + (for all D in Map'First .. C => + (if Map (D) = D then + Indexes (D) = 0 + else + Indexes (D) in 1 .. J + and then Result (Indexes (D)) = D)); + pragma Loop_Invariant + (for all Char of Result (1 .. J) => Map (Char) /= Char); end loop; return Result (1 .. J); @@ -146,7 +173,7 @@ package body Ada.Strings.Maps is function To_Mapping (From, To : Character_Sequence) return Character_Mapping is - Result : Character_Mapping; + Result : Character_Mapping with Relaxed_Initialization; Inserted : Character_Set := Null_Set; From_Len : constant Natural := From'Length; To_Len : constant Natural := To'Length; @@ -158,6 +185,9 @@ package body Ada.Strings.Maps is for Char in Character loop Result (Char) := Char; + pragma Loop_Invariant (Result (Result'First .. Char)'Initialized); + pragma Loop_Invariant + (for all C in Result'First .. Char => Result (C) = C); end loop; for J in From'Range loop @@ -167,6 +197,23 @@ package body Ada.Strings.Maps is Result (From (J)) := To (J - From'First + To'First); Inserted (From (J)) := True; + + pragma Loop_Invariant (Result'Initialized); + pragma Loop_Invariant + (for all K in From'First .. J => + Result (From (K)) = To (K - From'First + To'First) + and then Inserted (From (K))); + pragma Loop_Invariant + (for all Char in Character => + (Inserted (Char) = + (for some K in From'First .. J => Char = From (K)))); + pragma Loop_Invariant + (for all Char in Character => + (if not Inserted (Char) then Result (Char) = Char)); + pragma Loop_Invariant + (if (for all K in From'First .. J => + From (K) = To (J - From'First + To'First)) + then Result = Identity); end loop; return Result; @@ -176,19 +223,195 @@ package body Ada.Strings.Maps is -- To_Range -- -------------- - function To_Range (Map : Character_Mapping) return Character_Sequence - is - Result : String (1 .. Map'Length); + function To_Range (Map : Character_Mapping) return Character_Sequence is + + -- Extract from the postcondition of To_Domain the essential properties + -- that define Seq as the domain of Map. + function Is_Domain + (Map : Character_Mapping; + Seq : Character_Sequence) + return Boolean + is + (Seq'First = 1 + and then + SPARK_Proof_Sorted_Character_Sequence (Seq) + and then + (for all Char in Character => + (if (for all X of Seq => X /= Char) + then Map (Char) = Char)) + and then + (for all Char of Seq => Map (Char) /= Char)) + with + Ghost; + + -- Given Map, there is a unique sequence Seq for which + -- Is_Domain(Map,Seq) holds. + procedure Lemma_Domain_Unicity + (Map : Character_Mapping; + Seq1, Seq2 : Character_Sequence) + with + Ghost, + Pre => Is_Domain (Map, Seq1) + and then Is_Domain (Map, Seq2), + Post => Seq1 = Seq2; + + -- Isolate the proof that To_Domain(Map) returns a sequence for which + -- Is_Domain holds. + procedure Lemma_Is_Domain (Map : Character_Mapping) + with + Ghost, + Post => Is_Domain (Map, To_Domain (Map)); + + -- Deduce the alternative expression of sortedness from the one in + -- SPARK_Proof_Sorted_Character_Sequence which compares consecutive + -- elements. + procedure Lemma_Is_Sorted (Seq : Character_Sequence) + with + Ghost, + Pre => SPARK_Proof_Sorted_Character_Sequence (Seq), + Post => (for all J in Seq'Range => + (for all K in Seq'Range => + (if J < K then Seq (J) < Seq (K)))); + + -------------------------- + -- Lemma_Domain_Unicity -- + -------------------------- + + procedure Lemma_Domain_Unicity + (Map : Character_Mapping; + Seq1, Seq2 : Character_Sequence) + is + J : Positive := 1; + + begin + while J <= Seq1'Last + and then J <= Seq2'Last + and then Seq1 (J) = Seq2 (J) + loop + pragma Loop_Invariant + (Seq1 (Seq1'First .. J) = Seq2 (Seq2'First .. J)); + + if J = Positive'Last then + return; + end if; + + J := J + 1; + end loop; + + Lemma_Is_Sorted (Seq1); + Lemma_Is_Sorted (Seq2); + + if J <= Seq1'Last + and then J <= Seq2'Last + then + if Seq1 (J) < Seq2 (J) then + pragma Assert (for all X of Seq2 => X /= Seq1 (J)); + pragma Assert (Map (Seq1 (J)) = Seq1 (J)); + pragma Assert (False); + else + pragma Assert (for all X of Seq1 => X /= Seq2 (J)); + pragma Assert (Map (Seq2 (J)) = Seq2 (J)); + pragma Assert (False); + end if; + + elsif J <= Seq1'Last then + pragma Assert (for all X of Seq2 => X /= Seq1 (J)); + pragma Assert (Map (Seq1 (J)) = Seq1 (J)); + pragma Assert (False); + + elsif J <= Seq2'Last then + pragma Assert (for all X of Seq1 => X /= Seq2 (J)); + pragma Assert (Map (Seq2 (J)) = Seq2 (J)); + pragma Assert (False); + end if; + end Lemma_Domain_Unicity; + + --------------------- + -- Lemma_Is_Domain -- + --------------------- + + procedure Lemma_Is_Domain (Map : Character_Mapping) is + Ignore : constant Character_Sequence := To_Domain (Map); + begin + null; + end Lemma_Is_Domain; + + --------------------- + -- Lemma_Is_Sorted -- + --------------------- + + procedure Lemma_Is_Sorted (Seq : Character_Sequence) is + begin + for A in Seq'Range loop + exit when A = Positive'Last; + + for B in A + 1 .. Seq'Last loop + pragma Loop_Invariant + (for all K in A + 1 .. B => Seq (A) < Seq (K)); + end loop; + + pragma Loop_Invariant + (for all J in Seq'First .. A => + (for all K in Seq'Range => + (if J < K then Seq (J) < Seq (K)))); + end loop; + end Lemma_Is_Sorted; + + -- Local variables + + Result : String (1 .. Map'Length) with Relaxed_Initialization; J : Natural; + + -- Repeat the computation from To_Domain in ghost code, in order to + -- prove the relationship between Result and To_Domain(Map). + + Domain : String (1 .. Map'Length) with Ghost, Relaxed_Initialization; + type Character_Index is array (Character) of Natural with Ghost; + Indexes : Character_Index := (others => 0) with Ghost; + + -- Start of processing for To_Range + begin J := 0; for C in Map'Range loop if Map (C) /= C then J := J + 1; Result (J) := Map (C); + Domain (J) := C; + Indexes (C) := J; end if; + + -- Repeat the loop invariants from To_Domain regarding Domain and + -- Indexes. Add similar loop invariants for Result and Indexes. + + pragma Loop_Invariant (J <= Character'Pos (C) + 1); + pragma Loop_Invariant (Result (1 .. J)'Initialized); + pragma Loop_Invariant (Domain (1 .. J)'Initialized); + pragma Loop_Invariant (for all K in 1 .. J => Domain (K) <= C); + pragma Loop_Invariant + (SPARK_Proof_Sorted_Character_Sequence (Domain (1 .. J))); + pragma Loop_Invariant + (for all D in Map'First .. C => + (if Map (D) = D then + Indexes (D) = 0 + else + Indexes (D) in 1 .. J + and then Domain (Indexes (D)) = D + and then Result (Indexes (D)) = Map (D))); + pragma Loop_Invariant + (for all Char of Domain (1 .. J) => Map (Char) /= Char); + pragma Loop_Invariant + (for all K in 1 .. J => Result (K) = Map (Domain (K))); end loop; + -- Show the equality of Domain and To_Domain(Map) + + Lemma_Is_Domain (Map); + Lemma_Domain_Unicity (Map, Domain (1 .. J), To_Domain (Map)); + pragma Assert + (for all K in 1 .. J => Domain (K) = To_Domain (Map) (K)); + pragma Assert (To_Domain (Map)'Length = J); + return Result (1 .. J); end To_Range; @@ -197,18 +420,26 @@ package body Ada.Strings.Maps is --------------- function To_Ranges (Set : Character_Set) return Character_Ranges is - Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1); + Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1) + with Relaxed_Initialization; Range_Num : Natural; C : Character; + C_Iter : Character with Ghost; begin C := Character'First; Range_Num := 0; loop + C_Iter := C; + -- Skip gap between subsets while not Set (C) loop + pragma Loop_Invariant + (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); + pragma Loop_Invariant + (for all Char in C'Loop_Entry .. C => not Set (Char)); exit when C = Character'Last; C := Character'Succ (C); end loop; @@ -221,16 +452,45 @@ package body Ada.Strings.Maps is -- Span a subset loop + pragma Loop_Invariant + (Character'Pos (C) >= Character'Pos (C'Loop_Entry)); + pragma Loop_Invariant + (for all Char in C'Loop_Entry .. C => + (if Char /= C then Set (Char))); exit when not Set (C) or else C = Character'Last; C := Character'Succ (C); end loop; if Set (C) then - Max_Ranges (Range_Num). High := C; + Max_Ranges (Range_Num).High := C; exit; else - Max_Ranges (Range_Num). High := Character'Pred (C); + Max_Ranges (Range_Num).High := Character'Pred (C); end if; + + pragma Assert + (for all Char in C_Iter .. C => + (Set (Char) = + (Char in Max_Ranges (Range_Num).Low .. + Max_Ranges (Range_Num).High))); + pragma Assert + (for all Char in Character'First .. C_Iter => + (if Char /= C_Iter then + (Set (Char) = + (for some Span of Max_Ranges (1 .. Range_Num - 1) => + Char in Span.Low .. Span.High)))); + + pragma Loop_Invariant (2 * Range_Num <= Character'Pos (C) + 1); + pragma Loop_Invariant (Max_Ranges (1 .. Range_Num)'Initialized); + pragma Loop_Invariant (not Set (C)); + pragma Loop_Invariant + (for all Char in Character'First .. C => + (Set (Char) = + (for some Span of Max_Ranges (1 .. Range_Num) => + Char in Span.Low .. Span.High))); + pragma Loop_Invariant + (for all Span of Max_Ranges (1 .. Range_Num) => + (for all Char in Span.Low .. Span.High => Set (Char))); end loop; return Max_Ranges (1 .. Range_Num); @@ -241,7 +501,8 @@ package body Ada.Strings.Maps is ----------------- function To_Sequence (Set : Character_Set) return Character_Sequence is - Result : String (1 .. Character'Pos (Character'Last) + 1); + Result : String (1 .. Character'Pos (Character'Last) + 1) + with Relaxed_Initialization; Count : Natural := 0; begin for Char in Set'Range loop @@ -249,6 +510,17 @@ package body Ada.Strings.Maps is Count := Count + 1; Result (Count) := Char; end if; + + pragma Loop_Invariant (Count <= Character'Pos (Char) + 1); + pragma Loop_Invariant (Result (1 .. Count)'Initialized); + pragma Loop_Invariant (for all K in 1 .. Count => Result (K) <= Char); + pragma Loop_Invariant + (SPARK_Proof_Sorted_Character_Sequence (Result (1 .. Count))); + pragma Loop_Invariant + (for all C in Set'First .. Char => + (Set (C) = (for some X of Result (1 .. Count) => C = X))); + pragma Loop_Invariant + (for all Char of Result (1 .. Count) => Is_In (Char, Set)); end loop; return Result (1 .. Count); @@ -259,30 +531,37 @@ package body Ada.Strings.Maps is ------------ function To_Set (Ranges : Character_Ranges) return Character_Set is - Result : Character_Set; + Result : Character_Set := Null_Set; begin - for C in Result'Range loop - Result (C) := False; - end loop; - for R in Ranges'Range loop for C in Ranges (R).Low .. Ranges (R).High loop Result (C) := True; + pragma Loop_Invariant + (for all Char in Character => + Result (Char) = + ((for some Prev in Ranges'First .. R - 1 => + Char in Ranges (Prev).Low .. Ranges (Prev).High) + or else (Char in Ranges (R).Low .. C))); end loop; + + pragma Loop_Invariant + (for all Char in Character => + Result (Char) = + (for some Prev in Ranges'First .. R => + Char in Ranges (Prev).Low .. Ranges (Prev).High)); end loop; return Result; end To_Set; function To_Set (Span : Character_Range) return Character_Set is - Result : Character_Set; + Result : Character_Set := Null_Set; begin - for C in Result'Range loop - Result (C) := False; - end loop; - for C in Span.Low .. Span.High loop Result (C) := True; + pragma Loop_Invariant + (for all Char in Character => + Result (Char) = (Char in Span.Low .. C)); end loop; return Result; @@ -293,6 +572,10 @@ package body Ada.Strings.Maps is begin for J in Sequence'Range loop Result (Sequence (J)) := True; + pragma Loop_Invariant + (for all Char in Character => + Result (Char) = + (for some K in Sequence'First .. J => Char = Sequence (K))); end loop; return Result; @@ -313,8 +596,6 @@ package body Ada.Strings.Maps is (Map : Character_Mapping; Element : Character) return Character is - begin - return Map (Element); - end Value; + (Map (Element)); end Ada.Strings.Maps; diff --git a/gcc/ada/libgnat/a-strmap.ads b/gcc/ada/libgnat/a-strmap.ads index c35c392..1a15d5d 100644 --- a/gcc/ada/libgnat/a-strmap.ads +++ b/gcc/ada/libgnat/a-strmap.ads @@ -33,15 +33,24 @@ -- -- ------------------------------------------------------------------------------ +-- The package Strings.Maps defines the types, operations, and other entities +-- needed for character sets and character-to-character mappings. + -- 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. +-- setting the corresponding assertion policy to Ignore. Postconditions and +-- ghost code should not be executed at runtime as well, in order not to slow +-- down the execution of these functions. -pragma Assertion_Policy (Pre => Ignore); +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Ghost => Ignore); with Ada.Characters.Latin_1; -package Ada.Strings.Maps is +package Ada.Strings.Maps + with SPARK_Mode +is pragma Pure; -- In accordance with Ada 2005 AI-362 @@ -51,9 +60,10 @@ package Ada.Strings.Maps is type Character_Set is private; pragma Preelaborable_Initialization (Character_Set); - -- Representation for a set of character values: + -- An object of type Character_Set represents a set of characters. Null_Set : constant Character_Set; + -- Null_Set represents the set containing no characters. --------------------------- -- Constructors for Sets -- @@ -63,9 +73,12 @@ package Ada.Strings.Maps is Low : Character; High : Character; end record; - -- Represents Character range Low .. High + -- An object Obj of type Character_Range represents the set of characters + -- in the range Obj.Low .. Obj.High. type Character_Ranges is array (Positive range <>) of Character_Range; + -- An object Obj of type Character_Ranges represents the union of the sets + -- corresponding to Obj(I) for I in Obj'Range. function To_Set (Ranges : Character_Ranges) return Character_Set with Post => @@ -78,6 +91,8 @@ package Ada.Strings.Maps is (for all Span of Ranges => (for all Char in Span.Low .. Span.High => Is_In (Char, To_Set'Result))); + -- If Ranges'Length=0 then Null_Set is returned; otherwise, the returned + -- value represents the set corresponding to Ranges. function To_Set (Span : Character_Range) return Character_Set with Post => @@ -87,6 +102,7 @@ package Ada.Strings.Maps is (if Is_In (Char, To_Set'Result) then Char in Span.Low .. Span.High)) and then (for all Char in Span.Low .. Span.High => Is_In (Char, To_Set'Result)); + -- The returned value represents the set containing each character in Span. function To_Ranges (Set : Character_Set) return Character_Ranges with Post => @@ -100,6 +116,12 @@ package Ada.Strings.Maps is and then (for all Span of To_Ranges'Result => (for all Char in Span.Low .. Span.High => Is_In (Char, Set))); + -- If Set = Null_Set, then an empty Character_Ranges array is returned; + -- otherwise, the shortest array of contiguous ranges of Character values + -- in Set, in increasing order of Low, is returned. + -- + -- The postcondition above does not express that the result is the shortest + -- array and that it is sorted. ---------------------------------- -- Operations on Character Sets -- @@ -111,6 +133,13 @@ package Ada.Strings.Maps is = (for all Char in Character => (Is_In (Char, Left) = Is_In (Char, Right))); + -- The function "=" returns True if Left and Right represent identical + -- sets, and False otherwise. + + -- Each of the logical operators "not", "and", "or", and "xor" returns a + -- Character_Set value that represents the set obtained by applying the + -- corresponding operation to the set(s) represented by the parameter(s) + -- of the operator. function "not" (Right : Character_Set) return Character_Set with Post => @@ -146,10 +175,12 @@ package Ada.Strings.Maps is (Is_In (Char, "-"'Result) = (Is_In (Char, Left) and not Is_In (Char, Right)))); + -- "-"(Left, Right) is equivalent to "and"(Left, "not"(Right)). function Is_In (Element : Character; Set : Character_Set) return Boolean; + -- Is_In returns True if Element is in Set, and False otherwise. function Is_Subset (Elements : Character_Set; @@ -160,6 +191,8 @@ package Ada.Strings.Maps is = (for all Char in Character => (if Is_In (Char, Elements) then Is_In (Char, Set))); + -- Is_Subset returns True if Elements is a subset of Set, and False + -- otherwise. function "<=" (Left : Character_Set; @@ -167,7 +200,23 @@ package Ada.Strings.Maps is renames Is_Subset; subtype Character_Sequence is String; - -- Alternative representation for a set of character values + -- The Character_Sequence subtype is used to portray a set of character + -- values and also to identify the domain and range of a character mapping. + + function SPARK_Proof_Sorted_Character_Sequence + (Seq : Character_Sequence) return Boolean + is + (for all J in Seq'Range => + (if J /= Seq'Last then Seq (J) < Seq (J + 1))) + with + Ghost; + -- Check whether the Character_Sequence is sorted in stricly increasing + -- order, as expected from the result of To_Sequence and To_Domain. + + -- Sequence portrays the set of character values that it explicitly + -- contains (ignoring duplicates). Singleton portrays the set comprising a + -- single Character. Each of the To_Set functions returns a Character_Set + -- value that represents the set portrayed by Sequence or Singleton. function To_Set (Sequence : Character_Sequence) return Character_Set with Post => @@ -197,10 +246,10 @@ package Ada.Strings.Maps is and then (for all Char of To_Sequence'Result => Is_In (Char, Set)) and then - (for all J in To_Sequence'Result'Range => - (for all K in To_Sequence'Result'Range => - (if J /= K - then To_Sequence'Result (J) /= To_Sequence'Result (K)))); + SPARK_Proof_Sorted_Character_Sequence (To_Sequence'Result); + -- The function To_Sequence returns a Character_Sequence value containing + -- each of the characters in the set represented by Set, in ascending order + -- with no duplicates. ------------------------------------ -- Character Mapping Declarations -- @@ -208,13 +257,39 @@ package Ada.Strings.Maps is type Character_Mapping is private; pragma Preelaborable_Initialization (Character_Mapping); - -- Representation for a character to character mapping: + -- An object of type Character_Mapping represents a Character-to-Character + -- mapping. + + type SPARK_Proof_Character_Mapping_Model is + array (Character) of Character + with Ghost; + -- Publicly visible model of a Character_Mapping + + function SPARK_Proof_Model + (Map : Character_Mapping) + return SPARK_Proof_Character_Mapping_Model + with Ghost; + -- Creation of a publicly visible model of a Character_Mapping function Value (Map : Character_Mapping; - Element : Character) return Character; + Element : Character) return Character + with + Post => Value'Result = SPARK_Proof_Model (Map) (Element); + -- The function Value returns the Character value to which Element maps + -- with respect to the mapping represented by Map. + + -- A character C matches a pattern character P with respect to a given + -- Character_Mapping value Map if Value(Map, C) = P. A string S matches + -- a pattern string P with respect to a given Character_Mapping if + -- their lengths are the same and if each character in S matches its + -- corresponding character in the pattern string P. + + -- String handling subprograms that deal with character mappings have + -- parameters whose type is Character_Mapping. Identity : constant Character_Mapping; + -- Identity maps each Character to itself. ---------------------------- -- Operations on Mappings -- @@ -240,6 +315,10 @@ package Ada.Strings.Maps is and then (if (for all X of From => Char /= X) then Value (To_Mapping'Result, Char) = Char))); + -- To_Mapping produces a Character_Mapping such that each element of From + -- maps to the corresponding element of To, and each other character maps + -- to itself. If From'Length /= To'Length, or if some character is repeated + -- in From, then Translation_Error is propagated. function To_Domain (Map : Character_Mapping) return Character_Sequence with @@ -248,24 +327,40 @@ package Ada.Strings.Maps is and then To_Domain'Result'First = 1 and then + SPARK_Proof_Sorted_Character_Sequence (To_Domain'Result) + and then (for all Char in Character => (if (for all X of To_Domain'Result => X /= Char) then Value (Map, Char) = Char)) and then (for all Char of To_Domain'Result => Value (Map, Char) /= Char); + -- To_Domain returns the shortest Character_Sequence value D such that each + -- character not in D maps to itself, and such that the characters in D are + -- in ascending order. The lower bound of D is 1. function To_Range (Map : Character_Mapping) return Character_Sequence with Post => To_Range'Result'First = 1 and then - To_Range'Result'Last = To_Domain (Map)'Last + To_Range'Result'Length = To_Domain (Map)'Length and then (for all J in To_Range'Result'Range => To_Range'Result (J) = Value (Map, To_Domain (Map) (J))); + -- To_Range returns the Character_Sequence value R, such that if D = + -- To_Domain(Map), then R has the same bounds as D, and D(I) maps to + -- R(I) for each I in D'Range. + -- + -- A direct encoding of the Ada RM would be the postcondition + -- To_Range'Result'Last = To_Domain (Map)'Last + -- which is not provable unless the postcondition of To_Domain is also + -- strengthened to state the value of the high bound for an empty result. type Character_Mapping_Function is access function (From : Character) return Character; + -- An object F of type Character_Mapping_Function maps a Character value C + -- to the Character value F.all(C), which is said to match C with respect + -- to mapping function F. private pragma Inline (Is_In); @@ -285,6 +380,12 @@ private type Character_Mapping is array (Character) of Character; + function SPARK_Proof_Model + (Map : Character_Mapping) + return SPARK_Proof_Character_Mapping_Model + is + (SPARK_Proof_Character_Mapping_Model (Map)); + package L renames Ada.Characters.Latin_1; Identity : constant Character_Mapping := diff --git a/gcc/ada/libgnat/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads index 4396747..f4e7d36 100644 --- a/gcc/ada/libgnat/a-strsea.ads +++ b/gcc/ada/libgnat/a-strsea.ads @@ -213,7 +213,7 @@ package Ada.Strings.Search with SPARK_Mode is => Index'Result = 0, - -- Otherwise, a index in the range of Source is returned + -- Otherwise, an index in the range of Source is returned others => @@ -222,7 +222,7 @@ package Ada.Strings.Search with SPARK_Mode is Index'Result in Source'Range -- The character at the returned index satisfies the property - -- Test on Set + -- Test on Set. and then (Test = Inside) = Ada.Strings.Maps.Is_In (Source (Index'Result), Set) @@ -377,7 +377,7 @@ package Ada.Strings.Search with SPARK_Mode is => Index'Result = 0, - -- Otherwise, a index in the considered range of Source is returned + -- Otherwise, an index in the considered range of Source is returned others => diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index 1e85cc2..a94d6ca 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -29,10 +29,17 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Strings.Search; +-- Ghost code, loop invariants and assertions in this unit are meant for +-- analysis only, not for run-time checking, as it would be too costly +-- otherwise. This is enforced by setting the assertion policy to Ignore. -package body Ada.Strings.Superbounded is +pragma Assertion_Policy (Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); + +with Ada.Strings.Maps; use Ada.Strings.Maps; + +package body Ada.Strings.Superbounded with SPARK_Mode is ------------ -- Concat -- @@ -53,9 +60,13 @@ package body Ada.Strings.Superbounded is raise Ada.Strings.Length_Error; end if; - Result.Current_Length := Nlen; Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + + if Rlen > 0 then + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + + Result.Current_Length := Nlen; end; end return; end Concat; @@ -74,9 +85,13 @@ package body Ada.Strings.Superbounded is raise Ada.Strings.Length_Error; end if; - Result.Current_Length := Nlen; Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; + + if Right'Length > 0 then + Result.Data (Llen + 1 .. Nlen) := Super_String_Data (Right); + end if; + + Result.Current_Length := Nlen; end; end return; end Concat; @@ -97,9 +112,13 @@ package body Ada.Strings.Superbounded is raise Ada.Strings.Length_Error; end if; + Result.Data (1 .. Llen) := Super_String_Data (Left); + + if Rlen > 0 then + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); end; end return; end Concat; @@ -117,9 +136,9 @@ package body Ada.Strings.Superbounded is raise Ada.Strings.Length_Error; end if; - Result.Current_Length := Llen + 1; Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Current_Length) := Right; + Result.Data (Llen + 1) := Right; + Result.Current_Length := Llen + 1; end; end return; end Concat; @@ -137,10 +156,9 @@ package body Ada.Strings.Superbounded is raise Ada.Strings.Length_Error; end if; - Result.Current_Length := Rlen + 1; Result.Data (1) := Left; - Result.Data (2 .. Result.Current_Length) := - Right.Data (1 .. Rlen); + Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + Result.Current_Length := Rlen + 1; end; end return; end Concat; @@ -154,9 +172,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left.Current_Length = Right.Current_Length - and then Left.Data (1 .. Left.Current_Length) = - Right.Data (1 .. Right.Current_Length); + return Super_To_String (Left) = Super_To_String (Right); end "="; function Equal @@ -164,8 +180,7 @@ package body Ada.Strings.Superbounded is Right : String) return Boolean is begin - return Left.Current_Length = Right'Length - and then Left.Data (1 .. Left.Current_Length) = Right; + return Super_To_String (Left) = Right; end Equal; function Equal @@ -173,8 +188,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left'Length = Right.Current_Length - and then Left = Right.Data (1 .. Right.Current_Length); + return Left = Super_To_String (Right); end Equal; ------------- @@ -186,8 +200,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) > - Right.Data (1 .. Right.Current_Length); + return Super_To_String (Left) > Super_To_String (Right); end Greater; function Greater @@ -195,7 +208,7 @@ package body Ada.Strings.Superbounded is Right : String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) > Right; + return Super_To_String (Left) > Right; end Greater; function Greater @@ -203,7 +216,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left > Right.Data (1 .. Right.Current_Length); + return Left > Super_To_String (Right); end Greater; ---------------------- @@ -215,8 +228,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) >= - Right.Data (1 .. Right.Current_Length); + return Super_To_String (Left) >= Super_To_String (Right); end Greater_Or_Equal; function Greater_Or_Equal @@ -224,7 +236,7 @@ package body Ada.Strings.Superbounded is Right : String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) >= Right; + return Super_To_String (Left) >= Right; end Greater_Or_Equal; function Greater_Or_Equal @@ -232,7 +244,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left >= Right.Data (1 .. Right.Current_Length); + return Left >= Super_To_String (Right); end Greater_Or_Equal; ---------- @@ -244,8 +256,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) < - Right.Data (1 .. Right.Current_Length); + return Super_To_String (Left) < Super_To_String (Right); end Less; function Less @@ -253,7 +264,7 @@ package body Ada.Strings.Superbounded is Right : String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) < Right; + return Super_To_String (Left) < Right; end Less; function Less @@ -261,7 +272,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left < Right.Data (1 .. Right.Current_Length); + return Left < Super_To_String (Right); end Less; ------------------- @@ -273,8 +284,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) <= - Right.Data (1 .. Right.Current_Length); + return Super_To_String (Left) <= Super_To_String (Right); end Less_Or_Equal; function Less_Or_Equal @@ -282,7 +292,7 @@ package body Ada.Strings.Superbounded is Right : String) return Boolean is begin - return Left.Data (1 .. Left.Current_Length) <= Right; + return Super_To_String (Left) <= Right; end Less_Or_Equal; function Less_Or_Equal @@ -290,7 +300,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Boolean is begin - return Left <= Right.Data (1 .. Right.Current_Length); + return Left <= Super_To_String (Right); end Less_Or_Equal; ---------------------- @@ -307,20 +317,20 @@ package body Ada.Strings.Superbounded is begin if Slen <= Max_Length then + Target.Data (1 .. Slen) := Super_String_Data (Source); Target.Current_Length := Slen; - Target.Data (1 .. Slen) := Source; else case Drop is when Strings.Right => + Target.Data (1 .. Max_Length) := Super_String_Data + (Source (Source'First .. Source'First - 1 + Max_Length)); Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); when Strings.Left => + Target.Data (1 .. Max_Length) := Super_String_Data + (Source (Source'Last - (Max_Length - 1) .. Source'Last)); Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); when Strings.Error => raise Ada.Strings.Length_Error; @@ -343,17 +353,18 @@ package body Ada.Strings.Superbounded is Result : Super_String (Max_Length); Llen : constant Natural := Left.Current_Length; Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; + if Llen <= Max_Length - Rlen then Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - else - Result.Current_Length := Max_Length; + if Rlen > 0 then + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + end if; + + Result.Current_Length := Llen + Rlen; + else case Drop is when Strings.Right => if Llen >= Max_Length then -- only case is Llen = Max_Length @@ -379,6 +390,8 @@ package body Ada.Strings.Superbounded is when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -392,16 +405,15 @@ package body Ada.Strings.Superbounded is Max_Length : constant Positive := Source.Max_Length; Llen : constant Natural := Source.Current_Length; Rlen : constant Natural := New_Item.Current_Length; - Nlen : constant Natural := Llen + Rlen; begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); + if Llen <= Max_Length - Rlen then + if Rlen > 0 then + Source.Data (Llen + 1 .. Llen + Rlen) := New_Item.Data (1 .. Rlen); + Source.Current_Length := Llen + Rlen; + end if; else - Source.Current_Length := Max_Length; - case Drop is when Strings.Right => if Llen < Max_Length then @@ -423,6 +435,8 @@ package body Ada.Strings.Superbounded is when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Source.Current_Length := Max_Length; end if; end Super_Append; @@ -438,17 +452,18 @@ package body Ada.Strings.Superbounded is Result : Super_String (Max_Length); Llen : constant Natural := Left.Current_Length; Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Llen + Rlen; begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; + if Llen <= Max_Length - Rlen then Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - else - Result.Current_Length := Max_Length; + if Rlen > 0 then + Result.Data (Llen + 1 .. Llen + Rlen) := Super_String_Data (Right); + end if; + + Result.Current_Length := Llen + Rlen; + else case Drop is when Strings.Right => if Llen >= Max_Length then -- only case is Llen = Max_Length @@ -456,27 +471,29 @@ package body Ada.Strings.Superbounded is else Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right (Right'First .. Right'First - 1 + - Max_Length - Llen); + Result.Data (Llen + 1 .. Max_Length) := Super_String_Data + (Right + (Right'First .. Right'First - 1 - Llen + Max_Length)); end if; when Strings.Left => if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right (Right'Last - (Max_Length - 1) .. Right'Last); + Result.Data (1 .. Max_Length) := Super_String_Data + (Right (Right'Last - (Max_Length - 1) .. Right'Last)); else Result.Data (1 .. Max_Length - Rlen) := Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right; + Super_String_Data (Right); end if; when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -490,40 +507,42 @@ package body Ada.Strings.Superbounded is Max_Length : constant Positive := Source.Max_Length; Llen : constant Natural := Source.Current_Length; Rlen : constant Natural := New_Item'Length; - Nlen : constant Natural := Llen + Rlen; begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item; + if Llen <= Max_Length - Rlen then + if Rlen > 0 then + Source.Data (Llen + 1 .. Llen + Rlen) := + Super_String_Data (New_Item); + Source.Current_Length := Llen + Rlen; + end if; else - Source.Current_Length := Max_Length; - case Drop is when Strings.Right => if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item (New_Item'First .. - New_Item'First - 1 + Max_Length - Llen); + Source.Data (Llen + 1 .. Max_Length) := Super_String_Data + (New_Item (New_Item'First .. + New_Item'First - 1 - Llen + Max_Length)); end if; when Strings.Left => if Rlen >= Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - (Max_Length - 1) .. - New_Item'Last); + Source.Data (1 .. Max_Length) := Super_String_Data + (New_Item (New_Item'Last - (Max_Length - 1) .. + New_Item'Last)); else Source.Data (1 .. Max_Length - Rlen) := Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item; + Super_String_Data (New_Item); end if; when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Source.Current_Length := Max_Length; end if; end Super_Append; @@ -539,25 +558,25 @@ package body Ada.Strings.Superbounded is Result : Super_String (Max_Length); Llen : constant Natural := Left'Length; Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + if Llen <= Max_Length - Rlen then + Result.Data (1 .. Llen) := Super_String_Data (Left); - else - Result.Current_Length := Max_Length; + if Rlen > 0 then + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + end if; + Result.Current_Length := Llen + Rlen; + else case Drop is when Strings.Right => if Llen >= Max_Length then - Result.Data (1 .. Max_Length) := - Left (Left'First .. Left'First + (Max_Length - 1)); + Result.Data (1 .. Max_Length) := Super_String_Data + (Left (Left'First .. Left'First + (Max_Length - 1))); else - Result.Data (1 .. Llen) := Left; + Result.Data (1 .. Llen) := Super_String_Data (Left); Result.Data (Llen + 1 .. Max_Length) := Right.Data (1 .. Max_Length - Llen); end if; @@ -568,8 +587,8 @@ package body Ada.Strings.Superbounded is Right.Data (Rlen - (Max_Length - 1) .. Rlen); else - Result.Data (1 .. Max_Length - Rlen) := - Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); + Result.Data (1 .. Max_Length - Rlen) := Super_String_Data + (Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last)); Result.Data (Max_Length - Rlen + 1 .. Max_Length) := Right.Data (1 .. Rlen); end if; @@ -577,6 +596,8 @@ package body Ada.Strings.Superbounded is when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -595,9 +616,9 @@ package body Ada.Strings.Superbounded is begin if Llen < Max_Length then - Result.Current_Length := Llen + 1; Result.Data (1 .. Llen) := Left.Data (1 .. Llen); Result.Data (Llen + 1) := Right; + Result.Current_Length := Llen + 1; return Result; else @@ -606,10 +627,10 @@ package body Ada.Strings.Superbounded is return Left; when Strings.Left => - Result.Current_Length := Max_Length; Result.Data (1 .. Max_Length - 1) := Left.Data (2 .. Max_Length); Result.Data (Max_Length) := Right; + Result.Current_Length := Max_Length; return Result; when Strings.Error => @@ -628,12 +649,10 @@ package body Ada.Strings.Superbounded is begin if Llen < Max_Length then - Source.Current_Length := Llen + 1; Source.Data (Llen + 1) := New_Item; + Source.Current_Length := Llen + 1; else - Source.Current_Length := Max_Length; - case Drop is when Strings.Right => null; @@ -663,18 +682,18 @@ package body Ada.Strings.Superbounded is begin if Rlen < Max_Length then - Result.Current_Length := Rlen + 1; Result.Data (1) := Left; Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + Result.Current_Length := Rlen + 1; return Result; else case Drop is when Strings.Right => - Result.Current_Length := Max_Length; Result.Data (1) := Left; Result.Data (2 .. Max_Length) := Right.Data (1 .. Max_Length - 1); + Result.Current_Length := Max_Length; return Result; when Strings.Left => @@ -696,9 +715,7 @@ package body Ada.Strings.Superbounded is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is begin - return - Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + return Search.Count (Super_To_String (Source), Pattern, Mapping); end Super_Count; function Super_Count @@ -707,9 +724,7 @@ package body Ada.Strings.Superbounded is Mapping : Maps.Character_Mapping_Function) return Natural is begin - return - Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + return Search.Count (Super_To_String (Source), Pattern, Mapping); end Super_Count; function Super_Count @@ -717,7 +732,7 @@ package body Ada.Strings.Superbounded is Set : Maps.Character_Set) return Natural is begin - return Search.Count (Source.Data (1 .. Source.Current_Length), Set); + return Search.Count (Super_To_String (Source), Set); end Super_Count; ------------------ @@ -737,19 +752,19 @@ package body Ada.Strings.Superbounded is if Num_Delete <= 0 then return Source; - elsif From > Slen + 1 then + elsif From - 1 > Slen then raise Ada.Strings.Index_Error; elsif Through >= Slen then - Result.Current_Length := From - 1; Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + Result.Current_Length := From - 1; return Result; else - Result.Current_Length := Slen - Num_Delete; Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - Result.Data (From .. Result.Current_Length) := + Result.Data (From .. Slen - Num_Delete) := Source.Data (Through + 1 .. Slen); + Result.Current_Length := Slen - Num_Delete; return Result; end if; end Super_Delete; @@ -766,7 +781,7 @@ package body Ada.Strings.Superbounded is if Num_Delete <= 0 then return; - elsif From > Slen + 1 then + elsif From - 1 > Slen then raise Ada.Strings.Index_Error; elsif Through >= Slen then @@ -779,22 +794,6 @@ package body Ada.Strings.Superbounded is end if; end Super_Delete; - ------------------- - -- Super_Element -- - ------------------- - - function Super_Element - (Source : Super_String; - Index : Positive) return Character - is - begin - if Index <= Source.Current_Length then - return Source.Data (Index); - else - raise Strings.Index_Error; - end if; - end Super_Element; - ---------------------- -- Super_Find_Token -- ---------------------- @@ -809,7 +808,7 @@ package body Ada.Strings.Superbounded is is begin Search.Find_Token - (Source.Data (From .. Source.Current_Length), Set, Test, First, Last); + (Super_To_String (Source), Set, From, Test, First, Last); end Super_Find_Token; procedure Super_Find_Token @@ -820,8 +819,7 @@ package body Ada.Strings.Superbounded is Last : out Natural) is begin - Search.Find_Token - (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); + Search.Find_Token (Super_To_String (Source), Set, Test, First, Last); end Super_Find_Token; ---------------- @@ -841,21 +839,22 @@ package body Ada.Strings.Superbounded is begin if Npad <= 0 then - Result.Current_Length := Count; Result.Data (1 .. Count) := Source.Data (1 .. Count); + Result.Current_Length := Count; elsif Count <= Max_Length then - Result.Current_Length := Count; Result.Data (1 .. Slen) := Source.Data (1 .. Slen); Result.Data (Slen + 1 .. Count) := (others => Pad); + Result.Current_Length := Count; else - Result.Current_Length := Max_Length; - case Drop is when Strings.Right => Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + + if Slen < Max_Length then + Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + end if; when Strings.Left => if Npad >= Max_Length then @@ -871,6 +870,8 @@ package body Ada.Strings.Superbounded is when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -885,22 +886,22 @@ package body Ada.Strings.Superbounded is Max_Length : constant Positive := Source.Max_Length; Slen : constant Natural := Source.Current_Length; Npad : constant Integer := Count - Slen; - Temp : String (1 .. Max_Length); + Temp : Super_String_Data (1 .. Max_Length); begin if Npad <= 0 then Source.Current_Length := Count; elsif Count <= Max_Length then - Source.Current_Length := Count; Source.Data (Slen + 1 .. Count) := (others => Pad); + Source.Current_Length := Count; else - Source.Current_Length := Max_Length; - case Drop is when Strings.Right => - Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + if Slen < Max_Length then + Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + end if; when Strings.Left => if Npad > Max_Length then @@ -910,15 +911,15 @@ package body Ada.Strings.Superbounded is Temp := Source.Data; Source.Data (1 .. Max_Length - Npad) := Temp (Count - Max_Length + 1 .. Slen); - - for J in Max_Length - Npad + 1 .. Max_Length loop - Source.Data (J) := Pad; - end loop; + Source.Data (Max_Length - Npad + 1 .. Max_Length) := + (others => Pad); end if; when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Source.Current_Length := Max_Length; end if; end Super_Head; @@ -933,8 +934,7 @@ package body Ada.Strings.Superbounded is Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + return Search.Index (Super_To_String (Source), Pattern, Going, Mapping); end Super_Index; function Super_Index @@ -944,8 +944,7 @@ package body Ada.Strings.Superbounded is Mapping : Maps.Character_Mapping_Function) return Natural is begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + return Search.Index (Super_To_String (Source), Pattern, Going, Mapping); end Super_Index; function Super_Index @@ -955,8 +954,7 @@ package body Ada.Strings.Superbounded is Going : Strings.Direction := Strings.Forward) return Natural is begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Set, Test, Going); + return Search.Index (Super_To_String (Source), Set, Test, Going); end Super_Index; function Super_Index @@ -968,8 +966,7 @@ package body Ada.Strings.Superbounded is is begin return Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); + (Super_To_String (Source), Pattern, From, Going, Mapping); end Super_Index; function Super_Index @@ -981,8 +978,7 @@ package body Ada.Strings.Superbounded is is begin return Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); + (Super_To_String (Source), Pattern, From, Going, Mapping); end Super_Index; function Super_Index @@ -993,8 +989,15 @@ package body Ada.Strings.Superbounded is Going : Direction := Forward) return Natural is begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); + return Result : Natural do + Result := + Search.Index (Super_To_String (Source), Set, From, Test, Going); + pragma Assert + (if (for all J in 1 .. Super_Length (Source) => + (if J = From or else (J > From) = (Going = Forward) then + (Test = Inside) /= Maps.Is_In (Source.Data (J), Set))) + then Result = 0); + end return; end Super_Index; --------------------------- @@ -1006,9 +1009,7 @@ package body Ada.Strings.Superbounded is Going : Strings.Direction := Strings.Forward) return Natural is begin - return - Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), Going); + return Search.Index_Non_Blank (Super_To_String (Source), Going); end Super_Index_Non_Blank; function Super_Index_Non_Blank @@ -1017,9 +1018,7 @@ package body Ada.Strings.Superbounded is Going : Direction := Forward) return Natural is begin - return - Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), From, Going); + return Search.Index_Non_Blank (Super_To_String (Source), From, Going); end Super_Index_Non_Blank; ------------------ @@ -1031,60 +1030,71 @@ package body Ada.Strings.Superbounded is Before : Positive; New_Item : String; Drop : Strings.Truncation := Strings.Error) return Super_String + with SPARK_Mode => Off is Max_Length : constant Positive := Source.Max_Length; Result : Super_String (Max_Length); Slen : constant Natural := Source.Current_Length; Nlen : constant Natural := New_Item'Length; - Tlen : constant Natural := Slen + Nlen; Blen : constant Natural := Before - 1; Alen : constant Integer := Slen - Blen; - Droplen : constant Integer := Tlen - Max_Length; + Droplen : constant Integer := Slen - Max_Length + Nlen; - -- Tlen is the length of the total string before possible truncation. -- Blen, Alen are the lengths of the before and after pieces of the - -- source string. + -- source string. The number of dropped characters is Natural'Max (0, + -- Droplen). begin if Alen < 0 then raise Ada.Strings.Index_Error; elsif Droplen <= 0 then - Result.Current_Length := Tlen; Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Tlen) := - Source.Data (Before .. Slen); + Result.Data (Before .. Before - 1 + Nlen) := + Super_String_Data (New_Item); - else - Result.Current_Length := Max_Length; + if Before <= Slen then + Result.Data (Before + Nlen .. Slen + Nlen) := + Source.Data (Before .. Slen); + end if; + Result.Current_Length := Slen + Nlen; + + else case Drop is when Strings.Right => Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - if Droplen > Alen then - Result.Data (Before .. Max_Length) := - New_Item (New_Item'First - .. New_Item'First + Max_Length - Before); + if Droplen >= Alen then + Result.Data (Before .. Max_Length) := Super_String_Data + (New_Item (New_Item'First + .. New_Item'First - Before + Max_Length)); + pragma Assert + (String (Result.Data (Before .. Max_Length)) = + New_Item (New_Item'First + .. New_Item'First - Before + Max_Length)); else - Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before .. Before - 1 + Nlen) := + Super_String_Data (New_Item); Result.Data (Before + Nlen .. Max_Length) := Source.Data (Before .. Slen - Droplen); end if; when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (Before .. Slen); + if Alen > 0 then + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (Before .. Slen); + end if; - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - New_Item (New_Item'Last - (Max_Length - Alen) + 1 - .. New_Item'Last); + if Droplen > Blen then + if Alen < Max_Length then + Result.Data (1 .. Max_Length - Alen) := Super_String_Data + (New_Item (New_Item'Last - (Max_Length - Alen) + 1 + .. New_Item'Last)); + end if; else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := - New_Item; + Result.Data (Blen - Droplen + 1 .. Max_Length - Alen) := + Super_String_Data (New_Item); Result.Data (1 .. Blen - Droplen) := Source.Data (Droplen + 1 .. Blen); end if; @@ -1092,6 +1102,8 @@ package body Ada.Strings.Superbounded is when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -1111,15 +1123,6 @@ package body Ada.Strings.Superbounded is Source := Super_Insert (Source, Before, New_Item, Drop); end Super_Insert; - ------------------ - -- Super_Length -- - ------------------ - - function Super_Length (Source : Super_String) return Natural is - begin - return Source.Current_Length; - end Super_Length; - --------------------- -- Super_Overwrite -- --------------------- @@ -1132,61 +1135,61 @@ package body Ada.Strings.Superbounded is is Max_Length : constant Positive := Source.Max_Length; Result : Super_String (Max_Length); - Endpos : constant Natural := Position + New_Item'Length - 1; Slen : constant Natural := Source.Current_Length; Droplen : Natural; begin - if Position > Slen + 1 then + if Position - 1 > Slen then raise Ada.Strings.Index_Error; elsif New_Item'Length = 0 then return Source; - elsif Endpos <= Slen then - Result.Current_Length := Source.Current_Length; + elsif Position - 1 <= Slen - New_Item'Length then Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Position .. Endpos) := New_Item; + Result.Data (Position .. Position - 1 + New_Item'Length) := + Super_String_Data (New_Item); + Result.Current_Length := Source.Current_Length; return Result; - elsif Endpos <= Max_Length then - Result.Current_Length := Endpos; + elsif Position - 1 <= Max_Length - New_Item'Length then Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); - Result.Data (Position .. Endpos) := New_Item; + Result.Data (Position .. Position - 1 + New_Item'Length) := + Super_String_Data (New_Item); + Result.Current_Length := Position - 1 + New_Item'Length; return Result; else - Result.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; + Droplen := Position - 1 - Max_Length + New_Item'Length; case Drop is when Strings.Right => Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); - Result.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - return Result; + Result.Data (Position .. Max_Length) := Super_String_Data + (New_Item (New_Item'First .. New_Item'Last - Droplen)); when Strings.Left => if New_Item'Length >= Max_Length then - Result.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - return Result; + Result.Data (1 .. Max_Length) := Super_String_Data + (New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last)); else Result.Data (1 .. Max_Length - New_Item'Length) := Source.Data (Droplen + 1 .. Position - 1); Result.Data (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - return Result; + Super_String_Data (New_Item); end if; when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; + return Result; end if; end Super_Overwrite; @@ -1195,50 +1198,52 @@ package body Ada.Strings.Superbounded is Position : Positive; New_Item : String; Drop : Strings.Truncation := Strings.Error) + with SPARK_Mode => Off is Max_Length : constant Positive := Source.Max_Length; - Endpos : constant Positive := Position + New_Item'Length - 1; Slen : constant Natural := Source.Current_Length; Droplen : Natural; begin - if Position > Slen + 1 then + if Position - 1 > Slen then raise Ada.Strings.Index_Error; - elsif Endpos <= Slen then - Source.Data (Position .. Endpos) := New_Item; + elsif Position - 1 <= Slen - New_Item'Length then + Source.Data (Position .. Position - 1 + New_Item'Length) := + Super_String_Data (New_Item); - elsif Endpos <= Max_Length then - Source.Data (Position .. Endpos) := New_Item; - Source.Current_Length := Endpos; + elsif Position - 1 <= Max_Length - New_Item'Length then + Source.Data (Position .. Position - 1 + New_Item'Length) := + Super_String_Data (New_Item); + Source.Current_Length := Position - 1 + New_Item'Length; else - Source.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; + Droplen := Position - 1 - Max_Length + New_Item'Length; case Drop is when Strings.Right => - Source.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); + Source.Data (Position .. Max_Length) := Super_String_Data + (New_Item (New_Item'First .. New_Item'Last - Droplen)); when Strings.Left => if New_Item'Length > Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); + Source.Data (1 .. Max_Length) := Super_String_Data + (New_Item + (New_Item'Last - Max_Length + 1 .. New_Item'Last)); else Source.Data (1 .. Max_Length - New_Item'Length) := Source.Data (Droplen + 1 .. Position - 1); - Source.Data (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; + Super_String_Data (New_Item); end if; when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Source.Current_Length := Max_Length; end if; end Super_Overwrite; @@ -1269,12 +1274,13 @@ package body Ada.Strings.Superbounded is High : Natural; By : String; Drop : Strings.Truncation := Strings.Error) return Super_String + with SPARK_Mode => Off is Max_Length : constant Positive := Source.Max_Length; Slen : constant Natural := Source.Current_Length; begin - if Low > Slen + 1 then + if Low - 1 > Slen then raise Strings.Index_Error; elsif High < Low then @@ -1282,51 +1288,58 @@ package body Ada.Strings.Superbounded is else declare - Blen : constant Natural := Natural'Max (0, Low - 1); + Blen : constant Natural := Low - 1; Alen : constant Natural := Natural'Max (0, Slen - High); - Tlen : constant Natural := Blen + By'Length + Alen; - Droplen : constant Integer := Tlen - Max_Length; + Droplen : constant Integer := Blen + Alen - Max_Length + By'Length; Result : Super_String (Max_Length); - -- Tlen is the total length of the result string before any - -- truncation. Blen and Alen are the lengths of the pieces - -- of the original string that end up in the result string - -- before and after the replaced slice. + -- Blen and Alen are the lengths of the pieces of the original + -- string that end up in the result string before and after the + -- replaced slice. The number of dropped characters is Natural'Max + -- (0, Droplen). begin if Droplen <= 0 then - Result.Current_Length := Tlen; Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Tlen) := - Source.Data (High + 1 .. Slen); + Result.Data (Low .. Blen + By'Length) := + Super_String_Data (By); - else - Result.Current_Length := Max_Length; + if Alen > 0 then + Result.Data (Low + By'Length .. Blen + By'Length + Alen) := + Source.Data (High + 1 .. Slen); + end if; + Result.Current_Length := Blen + By'Length + Alen; + + else case Drop is when Strings.Right => Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - if Droplen > Alen then - Result.Data (Low .. Max_Length) := - By (By'First .. By'First + Max_Length - Low); + if Droplen >= Alen then + Result.Data (Low .. Max_Length) := Super_String_Data + (By (By'First .. By'First - Low + Max_Length)); else - Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low .. Low - 1 + By'Length) := + Super_String_Data (By); Result.Data (Low + By'Length .. Max_Length) := Source.Data (High + 1 .. Slen - Droplen); end if; when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (High + 1 .. Slen); + if Alen > 0 then + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (High + 1 .. Slen); + end if; if Droplen >= Blen then Result.Data (1 .. Max_Length - Alen) := - By (By'Last - (Max_Length - Alen) + 1 .. By'Last); + Super_String_Data (By + (By'Last - (Max_Length - Alen) + 1 .. By'Last)); else Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := By; + (Blen - Droplen + 1 .. Max_Length - Alen) := + Super_String_Data (By); Result.Data (1 .. Blen - Droplen) := Source.Data (Droplen + 1 .. Blen); end if; @@ -1334,6 +1347,8 @@ package body Ada.Strings.Superbounded is when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -1370,16 +1385,17 @@ package body Ada.Strings.Superbounded is begin if Count <= Max_Length then + Result.Data (1 .. Count) := (others => Item); Result.Current_Length := Count; elsif Drop = Strings.Error then raise Ada.Strings.Length_Error; else + Result.Data (1 .. Max_Length) := (others => Item); Result.Current_Length := Max_Length; end if; - Result.Data (1 .. Result.Current_Length) := (others => Item); return Result; end Super_Replicate; @@ -1389,52 +1405,203 @@ package body Ada.Strings.Superbounded is Drop : Truncation := Error; Max_Length : Positive) return Super_String is - Length : constant Integer := Count * Item'Length; Result : Super_String (Max_Length); - Indx : Positive; + Indx : Natural; + Ilen : constant Natural := Item'Length; + + -- Parts of the proof involving manipulations with the modulo operator + -- are complicated for the prover and can't be done automatically in + -- the global subprogram. That's why we isolate them in these two ghost + -- lemmas. + + procedure Lemma_Mod (K : Natural; Q : Natural) with + Ghost, + Pre => Ilen /= 0 + and then Q mod Ilen = 0 + and then K - Q in 0 .. Ilen - 1, + Post => K mod Ilen = K - Q; + -- Lemma_Mod is applied to an index considered in Lemma_Split to prove + -- that it has the right value modulo Item'Length. + + procedure Lemma_Mod_Zero (X : Natural) with + Ghost, + Pre => Ilen /= 0 + and then X mod Ilen = 0 + and then X <= Natural'Last - Ilen, + Post => (X + Ilen) mod Ilen = 0; + -- Lemma_Mod_Zero is applied to prove that the length of the range + -- of indexes considered in the loop, when dropping on the Left, is + -- a multiple of Item'Length. + + procedure Lemma_Split (Going : Direction) with + Ghost, + Pre => + Ilen /= 0 + and then Indx in 0 .. Max_Length - Ilen + and then + (if Going = Forward + then Indx mod Ilen = 0 + else (Max_Length - Indx - Ilen) mod Ilen = 0) + and then Result.Data (Indx + 1 .. Indx + Ilen)'Initialized + and then String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item, + Post => + (if Going = Forward then + (for all J in Indx + 1 .. Indx + Ilen => + Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)) + else + (for all J in Indx + 1 .. Indx + Ilen => + Result.Data (J) = + Item (Item'Last - (Max_Length - J) mod Ilen))); + -- Lemma_Split is used after Result.Data (Indx + 1 .. Indx + Ilen) is + -- updated to Item and concludes that the characters match for each + -- index when taken modulo Item'Length, as the considered slice starts + -- at index 1 (or ends at index Max_Length, if Going = Backward) modulo + -- Item'Length. + + --------------- + -- Lemma_Mod -- + --------------- + + procedure Lemma_Mod (K : Natural; Q : Natural) is null; + + -------------------- + -- Lemma_Mod_Zero -- + -------------------- + + procedure Lemma_Mod_Zero (X : Natural) is null; + + ----------------- + -- Lemma_Split -- + ----------------- + + procedure Lemma_Split (Going : Direction) is + begin + if Going = Forward then + for K in Indx + 1 .. Indx + Ilen loop + Lemma_Mod (K - 1, Indx); + pragma Loop_Invariant + (for all J in Indx + 1 .. K => + Result.Data (J) = Item (Item'First + (J - 1) mod Ilen)); + end loop; + else + for K in Indx + 1 .. Indx + Ilen loop + Lemma_Mod (Max_Length - K, Max_Length - Indx - Ilen); + pragma Loop_Invariant + (for all J in Indx + 1 .. K => + Result.Data (J) = + Item (Item'Last - (Max_Length - J) mod Ilen)); + end loop; + end if; + end Lemma_Split; begin - if Length <= Max_Length then - Result.Current_Length := Length; - - if Length > 0 then - Indx := 1; + if Count = 0 or else Ilen <= Max_Length / Count then + if Count * Ilen > 0 then + Indx := 0; for J in 1 .. Count loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; + Result.Data (Indx + 1 .. Indx + Ilen) := + Super_String_Data (Item); + pragma Assert + (for all K in 1 .. Ilen => + Result.Data (Indx + K) = Item (Item'First - 1 + K)); + pragma Assert + (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); + Lemma_Split (Forward); + Indx := Indx + Ilen; + pragma Loop_Invariant (Indx = J * Ilen); + pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. Indx => + Result.Data (K) = + Item (Item'First + (K - 1) mod Ilen)); end loop; end if; - else - Result.Current_Length := Max_Length; + Result.Current_Length := Count * Ilen; + else case Drop is when Strings.Right => - Indx := 1; - - while Indx + Item'Length <= Max_Length + 1 loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; + Indx := 0; + + while Indx < Max_Length - Ilen loop + Result.Data (Indx + 1 .. Indx + Ilen) := + Super_String_Data (Item); + pragma Assert + (for all K in 1 .. Ilen => + Result.Data (Indx + K) = Item (Item'First - 1 + K)); + pragma Assert + (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); + Lemma_Split (Forward); + Indx := Indx + Ilen; + pragma Loop_Invariant (Indx mod Ilen = 0); + pragma Loop_Invariant (Indx in 0 .. Max_Length - 1); + pragma Loop_Invariant (Result.Data (1 .. Indx)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. Indx => + Result.Data (K) = + Item (Item'First + (K - 1) mod Ilen)); end loop; - Result.Data (Indx .. Max_Length) := - Item (Item'First .. Item'First + Max_Length - Indx); + Result.Data (Indx + 1 .. Max_Length) := Super_String_Data + (Item (Item'First .. Item'First + (Max_Length - Indx - 1))); + pragma Assert + (for all J in Indx + 1 .. Max_Length => + Result.Data (J) = Item (Item'First - 1 - Indx + J)); + + for J in Indx + 1 .. Max_Length loop + Lemma_Mod (J - 1, Indx); + pragma Loop_Invariant + (for all K in 1 .. J => + Result.Data (K) = + Item (Item'First + (K - 1) mod Ilen)); + end loop; when Strings.Left => Indx := Max_Length; - while Indx - Item'Length >= 1 loop - Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; - Indx := Indx - Item'Length; + while Indx > Ilen loop + Indx := Indx - Ilen; + Result.Data (Indx + 1 .. Indx + Ilen) := + Super_String_Data (Item); + pragma Assert + (for all K in 1 .. Ilen => + Result.Data (Indx + K) = Item (Item'First - 1 + K)); + pragma Assert + (String (Result.Data (Indx + 1 .. Indx + Ilen)) = Item); + Lemma_Split (Backward); + Lemma_Mod_Zero (Max_Length - Indx - Ilen); + pragma Loop_Invariant + ((Max_Length - Indx) mod Ilen = 0); + pragma Loop_Invariant (Indx in 1 .. Max_Length); + pragma Loop_Invariant + (Result.Data (Indx + 1 .. Max_Length)'Initialized); + pragma Loop_Invariant + (for all K in Indx + 1 .. Max_Length => + Result.Data (K) = + Item (Item'Last - (Max_Length - K) mod Ilen)); end loop; Result.Data (1 .. Indx) := - Item (Item'Last - Indx + 1 .. Item'Last); + Super_String_Data (Item (Item'Last - Indx + 1 .. Item'Last)); + pragma Assert + (for all J in 1 .. Indx => + Result.Data (J) = Item (Item'Last - Indx + J)); + + for J in reverse 1 .. Indx loop + Lemma_Mod (Max_Length - J, Max_Length - Indx); + pragma Loop_Invariant + (for all K in J .. Max_Length => + Result.Data (K) = + Item (Item'Last - (Max_Length - K) mod Ilen)); + end loop; when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -1447,11 +1614,7 @@ package body Ada.Strings.Superbounded is is begin return - Super_Replicate - (Count, - Item.Data (1 .. Item.Current_Length), - Drop, - Item.Max_Length); + Super_Replicate (Count, Super_To_String (Item), Drop, Item.Max_Length); end Super_Replicate; ----------------- @@ -1461,42 +1624,20 @@ package body Ada.Strings.Superbounded is function Super_Slice (Source : Super_String; Low : Positive; - High : Natural) return String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - return R : String (Low .. High) do - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - end if; - - -- Note: in this case, superflat bounds are not a problem, we just - -- get the null string in accordance with normal Ada slice rules. - - R := Source.Data (Low .. High); - end return; - end Super_Slice; - - function Super_Slice - (Source : Super_String; - Low : Positive; High : Natural) return Super_String is begin return Result : Super_String (Source.Max_Length) do - if Low > Source.Current_Length + 1 + if Low - 1 > Source.Current_Length or else High > Source.Current_Length then raise Index_Error; end if; - -- Note: the Max operation here deals with the superflat case - - Result.Current_Length := Integer'Max (0, High - Low + 1); - Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); + if High >= Low then + Result.Data (1 .. High - Low + 1) := Source.Data (Low .. High); + Result.Current_Length := High - Low + 1; + end if; end return; end Super_Slice; @@ -1507,16 +1648,18 @@ package body Ada.Strings.Superbounded is High : Natural) is begin - if Low > Source.Current_Length + 1 + if Low - 1 > Source.Current_Length or else High > Source.Current_Length then raise Index_Error; end if; - -- Note: the Max operation here deals with the superflat case - - Target.Current_Length := Integer'Max (0, High - Low + 1); - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); + if High >= Low then + Target.Data (1 .. High - Low + 1) := Source.Data (Low .. High); + Target.Current_Length := High - Low + 1; + else + Target.Current_Length := 0; + end if; end Super_Slice; ---------------- @@ -1536,18 +1679,22 @@ package body Ada.Strings.Superbounded is begin if Npad <= 0 then - Result.Current_Length := Count; - Result.Data (1 .. Count) := - Source.Data (Slen - (Count - 1) .. Slen); + if Count > 0 then + Result.Data (1 .. Count) := + Source.Data (Slen - (Count - 1) .. Slen); + Result.Current_Length := Count; + end if; elsif Count <= Max_Length then - Result.Current_Length := Count; Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); - else - Result.Current_Length := Max_Length; + if Slen > 0 then + Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); + end if; + + Result.Current_Length := Count; + else case Drop is when Strings.Right => if Npad >= Max_Length then @@ -1567,6 +1714,8 @@ package body Ada.Strings.Superbounded is when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Result.Current_Length := Max_Length; end if; return Result; @@ -1582,22 +1731,27 @@ package body Ada.Strings.Superbounded is Slen : constant Natural := Source.Current_Length; Npad : constant Integer := Count - Slen; - Temp : constant String (1 .. Max_Length) := Source.Data; + Temp : constant Super_String_Data (1 .. Max_Length) := Source.Data; begin if Npad <= 0 then Source.Current_Length := Count; - Source.Data (1 .. Count) := - Temp (Slen - (Count - 1) .. Slen); + + if Count > 0 then + Source.Data (1 .. Count) := + Temp (Slen - (Count - 1) .. Slen); + end if; elsif Count <= Max_Length then - Source.Current_Length := Count; Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); - else - Source.Current_Length := Max_Length; + if Slen > 0 then + Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); + end if; + Source.Current_Length := Count; + + else case Drop is when Strings.Right => if Npad >= Max_Length then @@ -1610,31 +1764,19 @@ package body Ada.Strings.Superbounded is end if; when Strings.Left => - for J in 1 .. Max_Length - Slen loop - Source.Data (J) := Pad; - end loop; - + Source.Data (1 .. Max_Length - Slen) := (others => Pad); Source.Data (Max_Length - Slen + 1 .. Max_Length) := Temp (1 .. Slen); when Strings.Error => raise Ada.Strings.Length_Error; end case; + + Source.Current_Length := Max_Length; end if; end Super_Tail; --------------------- - -- Super_To_String -- - --------------------- - - function Super_To_String (Source : Super_String) return String is - begin - return R : String (1 .. Source.Current_Length) do - R := Source.Data (1 .. Source.Current_Length); - end return; - end Super_To_String; - - --------------------- -- Super_Translate -- --------------------- @@ -1645,12 +1787,15 @@ package body Ada.Strings.Superbounded is Result : Super_String (Source.Max_Length); begin - Result.Current_Length := Source.Current_Length; - for J in 1 .. Source.Current_Length loop Result.Data (J) := Value (Mapping, Source.Data (J)); + pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => + Result.Data (K) = Value (Mapping, Source.Data (K))); end loop; + Result.Current_Length := Source.Current_Length; return Result; end Super_Translate; @@ -1661,6 +1806,9 @@ package body Ada.Strings.Superbounded is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Value (Mapping, Source.Data (J)); + pragma Loop_Invariant + (for all K in 1 .. J => + Source.Data (K) = Value (Mapping, Source'Loop_Entry.Data (K))); end loop; end Super_Translate; @@ -1671,12 +1819,15 @@ package body Ada.Strings.Superbounded is Result : Super_String (Source.Max_Length); begin - Result.Current_Length := Source.Current_Length; - for J in 1 .. Source.Current_Length loop Result.Data (J) := Mapping.all (Source.Data (J)); + pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => + Result.Data (K) = Mapping (Source.Data (K))); end loop; + Result.Current_Length := Source.Current_Length; return Result; end Super_Translate; @@ -1687,6 +1838,9 @@ package body Ada.Strings.Superbounded is begin for J in 1 .. Source.Current_Length loop Source.Data (J) := Mapping.all (Source.Data (J)); + pragma Loop_Invariant + (for all K in 1 .. J => + Source.Data (K) = Mapping (Source'Loop_Entry.Data (K))); end loop; end Super_Translate; @@ -1699,24 +1853,62 @@ package body Ada.Strings.Superbounded is Side : Trim_End) return Super_String is Result : Super_String (Source.Max_Length); - Last : Natural := Source.Current_Length; - First : Positive := 1; + Last : constant Natural := Source.Current_Length; begin - if Side = Left or else Side = Both then - while First <= Last and then Source.Data (First) = ' ' loop - First := First + 1; - end loop; - end if; + case Side is + when Strings.Left => + declare + Low : constant Natural := + Super_Index_Non_Blank (Source, Forward); + begin + -- All blanks case - if Side = Right or else Side = Both then - while Last >= First and then Source.Data (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; + if Low = 0 then + return Result; + end if; + + Result.Data (1 .. Last - Low + 1) := Source.Data (Low .. Last); + Result.Current_Length := Last - Low + 1; + end; + + when Strings.Right => + declare + High : constant Natural := + Super_Index_Non_Blank (Source, Backward); + begin + -- All blanks case + + if High = 0 then + return Result; + end if; + + Result.Data (1 .. High) := Source.Data (1 .. High); + Result.Current_Length := High; + end; + + when Strings.Both => + declare + Low : constant Natural := + Super_Index_Non_Blank (Source, Forward); + begin + -- All blanks case + + if Low = 0 then + return Result; + end if; + + declare + High : constant Natural := + Super_Index_Non_Blank (Source, Backward); + begin + Result.Data (1 .. High - Low + 1) := + Source.Data (Low .. High); + Result.Current_Length := High - Low + 1; + end; + end; + end case; - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); return Result; end Super_Trim; @@ -1724,28 +1916,54 @@ package body Ada.Strings.Superbounded is (Source : in out Super_String; Side : Trim_End) is - Max_Length : constant Positive := Source.Max_Length; - Last : Natural := Source.Current_Length; - First : Positive := 1; - Temp : String (1 .. Max_Length); - + Last : constant Natural := Source.Current_Length; begin - Temp (1 .. Last) := Source.Data (1 .. Last); - - if Side = Left or else Side = Both then - while First <= Last and then Temp (First) = ' ' loop - First := First + 1; - end loop; - end if; + case Side is + when Strings.Left => + declare + Low : constant Natural := + Super_Index_Non_Blank (Source, Forward); + begin + -- All blanks case - if Side = Right or else Side = Both then - while Last >= First and then Temp (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); + if Low = 0 then + Source.Current_Length := 0; + else + Source.Data (1 .. Last - Low + 1) := + Source.Data (Low .. Last); + Source.Current_Length := Last - Low + 1; + end if; + end; + + when Strings.Right => + declare + High : constant Natural := + Super_Index_Non_Blank (Source, Backward); + begin + Source.Current_Length := High; + end; + + when Strings.Both => + declare + Low : constant Natural := + Super_Index_Non_Blank (Source, Forward); + begin + -- All blanks case + + if Low = 0 then + Source.Current_Length := 0; + else + declare + High : constant Natural := + Super_Index_Non_Blank (Source, Backward); + begin + Source.Data (1 .. High - Low + 1) := + Source.Data (Low .. High); + Source.Current_Length := High - Low + 1; + end; + end if; + end; + end case; end Super_Trim; function Super_Trim @@ -1754,22 +1972,31 @@ package body Ada.Strings.Superbounded is Right : Maps.Character_Set) return Super_String is Result : Super_String (Source.Max_Length); + Low : Natural; + High : Natural; begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := - Source.Data (First .. Last); - return Result; - end if; - end loop; - end if; - end loop; + Low := Super_Index (Source, Left, Outside, Forward); + + -- Case where source comprises only characters in Left + + if Low = 0 then + return Result; + end if; + + High := Super_Index (Source, Right, Outside, Backward); + + -- Case where source comprises only characters in Right + + if High = 0 then + return Result; + end if; + + if High >= Low then + Result.Data (1 .. High - Low + 1) := Source.Data (Low .. High); + Result.Current_Length := High - Low + 1; + end if; - Result.Current_Length := 0; return Result; end Super_Trim; @@ -1778,29 +2005,39 @@ package body Ada.Strings.Superbounded is Left : Maps.Character_Set; Right : Maps.Character_Set) is + Last : constant Natural := Source.Current_Length; + Temp : Super_String_Data (1 .. Last); + Low : Natural; + High : Natural; + begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - if First = 1 then - Source.Current_Length := Last; - return; - else - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := - Source.Data (First .. Last); - return; - end if; - end if; - end loop; + Temp := Source.Data (1 .. Last); + Low := Super_Index (Source, Left, Outside, Forward); + + -- Case where source comprises only characters in Left + + if Low = 0 then + Source.Current_Length := 0; + + else + High := Super_Index (Source, Right, Outside, Backward); + -- Case where source comprises only characters in Right + + if High = 0 then Source.Current_Length := 0; - return; - end if; - end loop; - Source.Current_Length := 0; + elsif Low = 1 then + Source.Current_Length := High; + + elsif High < Low then + Source.Current_Length := 0; + + else + Source.Data (1 .. High - Low + 1) := Temp (Low .. High); + Source.Current_Length := High - Low + 1; + end if; + end if; end Super_Trim; ----------- @@ -1819,11 +2056,14 @@ package body Ada.Strings.Superbounded is raise Ada.Strings.Length_Error; else - Result.Current_Length := Left; - for J in 1 .. Left loop Result.Data (J) := Right; + pragma Loop_Invariant (Result.Data (1 .. J)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => Result.Data (K) = Right); end loop; + + Result.Current_Length := Left; end if; return Result; @@ -1835,23 +2075,88 @@ package body Ada.Strings.Superbounded is Max_Length : Positive) return Super_String is Result : Super_String (Max_Length); - Pos : Positive := 1; + Pos : Natural := 0; Rlen : constant Natural := Right'Length; Nlen : constant Natural := Left * Rlen; + -- Parts of the proof involving manipulations with the modulo operator + -- are complicated for the prover and can't be done automatically in + -- the global subprogram. That's why we isolate them in these two ghost + -- lemmas. + + procedure Lemma_Mod (K : Integer) with + Ghost, + Pre => + Rlen /= 0 + and then Pos mod Rlen = 0 + and then Pos in 0 .. Max_Length - Rlen + and then K in Pos .. Pos + Rlen - 1, + Post => K mod Rlen = K - Pos; + -- Lemma_Mod is applied to an index considered in Lemma_Split to prove + -- that it has the right value modulo Right'Length. + + procedure Lemma_Split with + Ghost, + Pre => + Rlen /= 0 + and then Pos mod Rlen = 0 + and then Pos in 0 .. Max_Length - Rlen + and then Result.Data (1 .. Pos + Rlen)'Initialized + and then String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right, + Post => + (for all K in Pos + 1 .. Pos + Rlen => + Result.Data (K) = Right (Right'First + (K - 1) mod Rlen)); + -- Lemma_Split is used after Result.Data (Pos + 1 .. Pos + Rlen) is + -- updated to Right and concludes that the characters match for each + -- index when taken modulo Right'Length, as the considered slice starts + -- at index 1 modulo Right'Length. + + --------------- + -- Lemma_Mod -- + --------------- + + procedure Lemma_Mod (K : Integer) is null; + + ----------------- + -- Lemma_Split -- + ----------------- + + procedure Lemma_Split is + begin + for K in Pos + 1 .. Pos + Rlen loop + Lemma_Mod (K - 1); + pragma Loop_Invariant + (for all J in Pos + 1 .. K => + Result.Data (J) = Right (Right'First + (J - 1) mod Rlen)); + end loop; + end Lemma_Split; + begin if Nlen > Max_Length then raise Ada.Strings.Length_Error; else - Result.Current_Length := Nlen; - if Nlen > 0 then for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := Right; + Result.Data (Pos + 1 .. Pos + Rlen) := + Super_String_Data (Right); + pragma Assert + (for all K in 1 .. Rlen => Result.Data (Pos + K) = + Right (Right'First - 1 + K)); + pragma Assert + (String (Result.Data (Pos + 1 .. Pos + Rlen)) = Right); + Lemma_Split; Pos := Pos + Rlen; + pragma Loop_Invariant (Pos = J * Rlen); + pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. Pos => + Result.Data (K) = + Right (Right'First + (K - 1) mod Rlen)); end loop; end if; + + Result.Current_Length := Nlen; end if; return Result; @@ -1862,7 +2167,7 @@ package body Ada.Strings.Superbounded is Right : Super_String) return Super_String is Result : Super_String (Right.Max_Length); - Pos : Positive := 1; + Pos : Natural := 0; Rlen : constant Natural := Right.Current_Length; Nlen : constant Natural := Left * Rlen; @@ -1871,15 +2176,21 @@ package body Ada.Strings.Superbounded is raise Ada.Strings.Length_Error; else - Result.Current_Length := Nlen; - if Nlen > 0 then for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := + Result.Data (Pos + 1 .. Pos + Rlen) := Right.Data (1 .. Rlen); Pos := Pos + Rlen; + pragma Loop_Invariant (Pos = J * Rlen); + pragma Loop_Invariant (Result.Data (1 .. Pos)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. Pos => + Result.Data (K) = + Right.Data (1 + (K - 1) mod Rlen)); end loop; end if; + + Result.Current_Length := Nlen; end if; return Result; @@ -1891,7 +2202,7 @@ package body Ada.Strings.Superbounded is function To_Super_String (Source : String; - Max_Length : Natural; + Max_Length : Positive; Drop : Truncation := Error) return Super_String is Result : Super_String (Max_Length); @@ -1899,20 +2210,20 @@ package body Ada.Strings.Superbounded is begin if Slen <= Max_Length then + Result.Data (1 .. Slen) := Super_String_Data (Source); Result.Current_Length := Slen; - Result.Data (1 .. Slen) := Source; else case Drop is when Strings.Right => + Result.Data (1 .. Max_Length) := Super_String_Data + (Source (Source'First .. Source'First - 1 + Max_Length)); Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); when Strings.Left => + Result.Data (1 .. Max_Length) := Super_String_Data + (Source (Source'Last - (Max_Length - 1) .. Source'Last)); Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); when Strings.Error => raise Ada.Strings.Length_Error; diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads index 9e568a8..7428e9c 100644 --- a/gcc/ada/libgnat/a-strsup.ads +++ b/gcc/ada/libgnat/a-strsup.ads @@ -36,28 +36,47 @@ -- length as the discriminant. Individual instantiations of Strings.Bounded -- use this type with an appropriate discriminant value set. -with Ada.Strings.Maps; +-- 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. Postconditions and +-- contract cases should not be executed at runtime as well, in order not to +-- slow down the execution of these functions. -package Ada.Strings.Superbounded is +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore); + +with Ada.Strings.Maps; use type Ada.Strings.Maps.Character_Mapping_Function; +with Ada.Strings.Search; + +package Ada.Strings.Superbounded with SPARK_Mode is pragma Preelaborate; -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is -- derived from Super_String, with the constraint of the maximum length. + type Super_String_Data is new String with Relaxed_Initialization; + type Super_String (Max_Length : Positive) is record Current_Length : Natural := 0; - Data : String (1 .. Max_Length); + Data : Super_String_Data (1 .. Max_Length); -- A previous version had a default initial value for Data, which is -- no longer necessary, because we now special-case this type in the -- compiler, so "=" composes properly for descendants of this type. -- Leaving it out is more efficient. - end record; + end record + with + Predicate => + Current_Length <= Max_Length + and then Data (1 .. Current_Length)'Initialized; -- The subprograms defined for Super_String are similar to those -- defined for Bounded_String, except that they have different names, so -- that they can be renamed in Ada.Strings.Bounded.Generic_Bounded_Length. - function Super_Length (Source : Super_String) return Natural; + function Super_Length (Source : Super_String) return Natural + is (Source.Current_Length); -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- @@ -65,109 +84,606 @@ package Ada.Strings.Superbounded is function To_Super_String (Source : String; - Max_Length : Natural; - Drop : Truncation := Error) return Super_String; + Max_Length : Positive; + Drop : Truncation := Error) return Super_String + with + Pre => (if Source'Length > Max_Length then Drop /= Error), + Post => To_Super_String'Result.Max_Length = Max_Length, + Contract_Cases => + (Source'Length <= Max_Length + => + Super_To_String (To_Super_String'Result) = Source, + + Source'Length > Max_Length and then Drop = Left + => + Super_To_String (To_Super_String'Result) = + Source (Source'Last - Max_Length + 1 .. Source'Last), + + others -- Drop = Right + => + Super_To_String (To_Super_String'Result) = + Source (Source'First .. Source'First - 1 + Max_Length)), + Global => null; -- Note the additional parameter Max_Length, which specifies the maximum -- length setting of the resulting Super_String value. -- The following procedures have declarations (and semantics) that are -- exactly analogous to those declared in Ada.Strings.Bounded. - function Super_To_String (Source : Super_String) return String; + function Super_To_String (Source : Super_String) return String + is (String (Source.Data (1 .. Source.Current_Length))); procedure Set_Super_String (Target : out Super_String; Source : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => + (if Source'Length > Target.Max_Length then Drop /= Error), + Contract_Cases => + (Source'Length <= Target.Max_Length + => + Super_To_String (Target) = Source, + + Source'Length > Target.Max_Length and then Drop = Left + => + Super_To_String (Target) = + Source (Source'Last - Target.Max_Length + 1 .. Source'Last), + + others -- Drop = Right + => + Super_To_String (Target) = + Source (Source'First .. Source'First - 1 + Target.Max_Length)), + Global => null; function Super_Append (Left : Super_String; Right : Super_String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + Left.Max_Length = Right.Max_Length + and then + (if Super_Length (Left) > Left.Max_Length - Super_Length (Right) + then Drop /= Error), + Post => Super_Append'Result.Max_Length = Left.Max_Length, + Contract_Cases => + (Super_Length (Left) <= Left.Max_Length - Super_Length (Right) + => + Super_Length (Super_Append'Result) = + Super_Length (Left) + Super_Length (Right) + and then + Super_Slice (Super_Append'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then + (if Super_Length (Right) > 0 then + Super_Slice (Super_Append'Result, + Super_Length (Left) + 1, + Super_Length (Super_Append'Result)) = + Super_To_String (Right)), + + Super_Length (Left) > Left.Max_Length - Super_Length (Right) + and then Drop = Strings.Left + => + Super_Length (Super_Append'Result) = Left.Max_Length + and then + (if Super_Length (Right) < Left.Max_Length then + String'(Super_Slice (Super_Append'Result, + 1, Left.Max_Length - Super_Length (Right))) = + Super_Slice (Left, + Super_Length (Left) - Left.Max_Length + + Super_Length (Right) + 1, + Super_Length (Left))) + and then + Super_Slice (Super_Append'Result, + Left.Max_Length - Super_Length (Right) + 1, Left.Max_Length) = + Super_To_String (Right), + + others -- Drop = Right + => + Super_Length (Super_Append'Result) = Left.Max_Length + and then + Super_Slice (Super_Append'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then + (if Super_Length (Left) < Left.Max_Length then + String'(Super_Slice (Super_Append'Result, + Super_Length (Left) + 1, Left.Max_Length)) = + Super_Slice (Right, + 1, Left.Max_Length - Super_Length (Left)))), + Global => null; function Super_Append (Left : Super_String; Right : String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + (if Right'Length > Left.Max_Length - Super_Length (Left) + then Drop /= Error), + Post => Super_Append'Result.Max_Length = Left.Max_Length, + Contract_Cases => + (Super_Length (Left) <= Left.Max_Length - Right'Length + => + Super_Length (Super_Append'Result) = + Super_Length (Left) + Right'Length + and then + Super_Slice (Super_Append'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then + (if Right'Length > 0 then + Super_Slice (Super_Append'Result, + Super_Length (Left) + 1, + Super_Length (Super_Append'Result)) = + Right), + + Super_Length (Left) > Left.Max_Length - Right'Length + and then Drop = Strings.Left + => + Super_Length (Super_Append'Result) = Left.Max_Length + and then + (if Right'Length < Left.Max_Length then + + -- The result is the end of Left followed by Right + + String'(Super_Slice (Super_Append'Result, + 1, Left.Max_Length - Right'Length)) = + Super_Slice (Left, + Super_Length (Left) - Left.Max_Length + Right'Length + + 1, + Super_Length (Left)) + and then + Super_Slice (Super_Append'Result, + Left.Max_Length - Right'Length + 1, Left.Max_Length) = + Right + else + -- The result is the last Max_Length characters of Right + + Super_To_String (Super_Append'Result) = + Right (Right'Last - Left.Max_Length + 1 .. Right'Last)), + + others -- Drop = Right + => + Super_Length (Super_Append'Result) = Left.Max_Length + and then + Super_Slice (Super_Append'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then + (if Super_Length (Left) < Left.Max_Length then + Super_Slice (Super_Append'Result, + Super_Length (Left) + 1, Left.Max_Length) = + Right (Right'First + .. Left.Max_Length - Super_Length (Left) + - 1 + Right'First))), + Global => null; function Super_Append (Left : String; Right : Super_String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + (if Left'Length > Right.Max_Length - Super_Length (Right) + then Drop /= Error), + Post => Super_Append'Result.Max_Length = Right.Max_Length, + Contract_Cases => + (Left'Length <= Right.Max_Length - Super_Length (Right) + => + Super_Length (Super_Append'Result) = + Left'Length + Super_Length (Right) + and then Super_Slice (Super_Append'Result, 1, Left'Length) = Left + and then + (if Super_Length (Right) > 0 then + Super_Slice (Super_Append'Result, + Left'Length + 1, Super_Length (Super_Append'Result)) = + Super_To_String (Right)), + + Left'Length > Right.Max_Length - Super_Length (Right) + and then Drop = Strings.Left + => + Super_Length (Super_Append'Result) = Right.Max_Length + and then + (if Super_Length (Right) < Right.Max_Length then + Super_Slice (Super_Append'Result, + 1, Right.Max_Length - Super_Length (Right)) = + Left + (Left'Last - Right.Max_Length + Super_Length (Right) + 1 + .. Left'Last)) + and then + Super_Slice (Super_Append'Result, + Right.Max_Length - Super_Length (Right) + 1, + Right.Max_Length) = + Super_To_String (Right), + + others -- Drop = Right + => + Super_Length (Super_Append'Result) = Right.Max_Length + and then + (if Left'Length < Right.Max_Length then + + -- The result is Left followed by the beginning of Right + + Super_Slice (Super_Append'Result, 1, Left'Length) = Left + and then + String'(Super_Slice (Super_Append'Result, + Left'Length + 1, Right.Max_Length)) = + Super_Slice (Right, 1, Right.Max_Length - Left'Length) + else + -- The result is the first Max_Length characters of Left + + Super_To_String (Super_Append'Result) = + Left (Left'First .. Right.Max_Length - 1 + Left'First))), + Global => null; function Super_Append (Left : Super_String; Right : Character; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + (if Super_Length (Left) = Left.Max_Length then Drop /= Error), + Post => Super_Append'Result.Max_Length = Left.Max_Length, + Contract_Cases => + (Super_Length (Left) < Left.Max_Length + => + Super_Length (Super_Append'Result) = Super_Length (Left) + 1 + and then + Super_Slice (Super_Append'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then + Super_Element (Super_Append'Result, Super_Length (Left) + 1) = + Right, + + Super_Length (Left) = Left.Max_Length and then Drop = Strings.Right + => + Super_Length (Super_Append'Result) = Left.Max_Length + and then + Super_To_String (Super_Append'Result) = Super_To_String (Left), + + others -- Drop = Left + => + Super_Length (Super_Append'Result) = Left.Max_Length + and then + String'(Super_Slice (Super_Append'Result, + 1, Left.Max_Length - 1)) = + Super_Slice (Left, 2, Left.Max_Length) + and then + Super_Element (Super_Append'Result, Left.Max_Length) = Right), + Global => null; function Super_Append (Left : Character; Right : Super_String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + (if Super_Length (Right) = Right.Max_Length then Drop /= Error), + Post => Super_Append'Result.Max_Length = Right.Max_Length, + Contract_Cases => + (Super_Length (Right) < Right.Max_Length + => + Super_Length (Super_Append'Result) = Super_Length (Right) + 1 + and then + Super_Slice (Super_Append'Result, 2, Super_Length (Right) + 1) = + Super_To_String (Right) + and then Super_Element (Super_Append'Result, 1) = Left, + + Super_Length (Right) = Right.Max_Length and then Drop = Strings.Left + => + Super_Length (Super_Append'Result) = Right.Max_Length + and then + Super_To_String (Super_Append'Result) = Super_To_String (Right), + + others -- Drop = Right + => + Super_Length (Super_Append'Result) = Right.Max_Length + and then + String'(Super_Slice (Super_Append'Result, 2, Right.Max_Length)) = + Super_Slice (Right, 1, Right.Max_Length - 1) + and then Super_Element (Super_Append'Result, 1) = Left), + Global => null; procedure Super_Append (Source : in out Super_String; New_Item : Super_String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => + Source.Max_Length = New_Item.Max_Length + and then + (if Super_Length (Source) > + Source.Max_Length - Super_Length (New_Item) + then Drop /= Error), + Contract_Cases => + (Super_Length (Source) <= Source.Max_Length - Super_Length (New_Item) + => + Super_Length (Source) = + Super_Length (Source'Old) + Super_Length (New_Item) + and then + Super_Slice (Source, 1, Super_Length (Source'Old)) = + Super_To_String (Source'Old) + and then + (if Super_Length (New_Item) > 0 then + Super_Slice (Source, + Super_Length (Source'Old) + 1, Super_Length (Source)) = + Super_To_String (New_Item)), + + Super_Length (Source) > Source.Max_Length - Super_Length (New_Item) + and then Drop = Left + => + Super_Length (Source) = Source.Max_Length + and then + (if Super_Length (New_Item) < Source.Max_Length then + String'(Super_Slice (Source, + 1, Source.Max_Length - Super_Length (New_Item))) = + Super_Slice (Source'Old, + Super_Length (Source'Old) - Source.Max_Length + + Super_Length (New_Item) + 1, + Super_Length (Source'Old))) + and then + Super_Slice (Source, + Source.Max_Length - Super_Length (New_Item) + 1, + Source.Max_Length) = + Super_To_String (New_Item), + + others -- Drop = Right + => + Super_Length (Source) = Source.Max_Length + and then + Super_Slice (Source, 1, Super_Length (Source'Old)) = + Super_To_String (Source'Old) + and then + (if Super_Length (Source'Old) < Source.Max_Length then + String'(Super_Slice (Source, + Super_Length (Source'Old) + 1, Source.Max_Length)) = + Super_Slice (New_Item, + 1, Source.Max_Length - Super_Length (Source'Old)))), + Global => null; procedure Super_Append (Source : in out Super_String; New_Item : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => + (if New_Item'Length > Source.Max_Length - Super_Length (Source) + then Drop /= Error), + Contract_Cases => + (Super_Length (Source) <= Source.Max_Length - New_Item'Length + => + Super_Length (Source) = Super_Length (Source'Old) + New_Item'Length + and then + Super_Slice (Source, 1, Super_Length (Source'Old)) = + Super_To_String (Source'Old) + and then + (if New_Item'Length > 0 then + Super_Slice (Source, + Super_Length (Source'Old) + 1, Super_Length (Source)) = + New_Item), + + Super_Length (Source) > Source.Max_Length - New_Item'Length + and then Drop = Left + => + Super_Length (Source) = Source.Max_Length + and then + (if New_Item'Length < Source.Max_Length then + + -- The result is the end of Source followed by New_Item + + String'(Super_Slice (Source, + 1, Source.Max_Length - New_Item'Length)) = + Super_Slice (Source'Old, + Super_Length (Source'Old) - Source.Max_Length + + New_Item'Length + 1, + Super_Length (Source'Old)) + and then + Super_Slice (Source, + Source.Max_Length - New_Item'Length + 1, + Source.Max_Length) = + New_Item + else + -- The result is the last Max_Length characters of + -- New_Item. + + Super_To_String (Source) = New_Item + (New_Item'Last - Source.Max_Length + 1 .. New_Item'Last)), + + others -- Drop = Right + => + Super_Length (Source) = Source.Max_Length + and then + Super_Slice (Source, 1, Super_Length (Source'Old)) = + Super_To_String (Source'Old) + and then + (if Super_Length (Source'Old) < Source.Max_Length then + Super_Slice (Source, + Super_Length (Source'Old) + 1, Source.Max_Length) = + New_Item (New_Item'First + .. Source.Max_Length - Super_Length (Source'Old) - 1 + + New_Item'First))), + Global => null; procedure Super_Append (Source : in out Super_String; New_Item : Character; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => + (if Super_Length (Source) = Source.Max_Length then Drop /= Error), + Contract_Cases => + (Super_Length (Source) < Source.Max_Length + => + Super_Length (Source) = Super_Length (Source'Old) + 1 + and then + Super_Slice (Source, 1, Super_Length (Source'Old)) = + Super_To_String (Source'Old) + and then + Super_Element (Source, Super_Length (Source'Old) + 1) = New_Item, + + Super_Length (Source) = Source.Max_Length and then Drop = Right + => + Super_Length (Source) = Source.Max_Length + and then Super_To_String (Source) = Super_To_String (Source'Old), + + others -- Drop = Left + => + Super_Length (Source) = Source.Max_Length + and then + String'(Super_Slice (Source, 1, Source.Max_Length - 1)) = + Super_Slice (Source'Old, 2, Source.Max_Length) + and then Super_Element (Source, Source.Max_Length) = New_Item), + Global => null; function Concat (Left : Super_String; - Right : Super_String) return Super_String; + Right : Super_String) return Super_String + with + Pre => Left.Max_Length = Right.Max_Length + and then Super_Length (Left) <= Left.Max_Length - Super_Length (Right), + Post => Concat'Result.Max_Length = Left.Max_Length + and then + Super_Length (Concat'Result) = + Super_Length (Left) + Super_Length (Right) + and then + Super_Slice (Concat'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then + (if Super_Length (Right) > 0 then + Super_Slice (Concat'Result, + Super_Length (Left) + 1, Super_Length (Concat'Result)) = + Super_To_String (Right)), + Global => null; function Concat (Left : Super_String; - Right : String) return Super_String; + Right : String) return Super_String + with + Pre => Right'Length <= Left.Max_Length - Super_Length (Left), + Post => Concat'Result.Max_Length = Left.Max_Length + and then + Super_Length (Concat'Result) = Super_Length (Left) + Right'Length + and then + Super_Slice (Concat'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then + (if Right'Length > 0 then + Super_Slice (Concat'Result, + Super_Length (Left) + 1, Super_Length (Concat'Result)) = + Right), + Global => null; function Concat (Left : String; - Right : Super_String) return Super_String; + Right : Super_String) return Super_String + with + Pre => Left'Length <= Right.Max_Length - Super_Length (Right), + Post => Concat'Result.Max_Length = Right.Max_Length + and then + Super_Length (Concat'Result) = Left'Length + Super_Length (Right) + and then Super_Slice (Concat'Result, 1, Left'Length) = Left + and then + (if Super_Length (Right) > 0 then + Super_Slice (Concat'Result, + Left'Length + 1, Super_Length (Concat'Result)) = + Super_To_String (Right)), + Global => null; function Concat (Left : Super_String; - Right : Character) return Super_String; + Right : Character) return Super_String + with + Pre => Super_Length (Left) < Left.Max_Length, + Post => Concat'Result.Max_Length = Left.Max_Length + and then Super_Length (Concat'Result) = Super_Length (Left) + 1 + and then + Super_Slice (Concat'Result, 1, Super_Length (Left)) = + Super_To_String (Left) + and then Super_Element (Concat'Result, Super_Length (Left) + 1) = Right, + Global => null; function Concat (Left : Character; - Right : Super_String) return Super_String; + Right : Super_String) return Super_String + with + Pre => Super_Length (Right) < Right.Max_Length, + Post => Concat'Result.Max_Length = Right.Max_Length + and then Super_Length (Concat'Result) = 1 + Super_Length (Right) + and then Super_Element (Concat'Result, 1) = Left + and then + Super_Slice (Concat'Result, 2, Super_Length (Concat'Result)) = + Super_To_String (Right), + Global => null; function Super_Element (Source : Super_String; - Index : Positive) return Character; + Index : Positive) return Character + is (if Index <= Source.Current_Length + then Source.Data (Index) + else raise Index_Error) + with Pre => Index <= Super_Length (Source); procedure Super_Replace_Element (Source : in out Super_String; Index : Positive; - By : Character); + By : Character) + with + Pre => Index <= Super_Length (Source), + Post => Super_Length (Source) = Super_Length (Source'Old) + and then + (for all K in 1 .. Super_Length (Source) => + Super_Element (Source, K) = + (if K = Index then By else Super_Element (Source'Old, K))), + Global => null; function Super_Slice (Source : Super_String; Low : Positive; - High : Natural) return String; + High : Natural) return String + is (if Low - 1 > Source.Current_Length or else High > Source.Current_Length + + -- Note: test of High > Length is in accordance with AI95-00128 + + then raise Index_Error + else + -- Note: in this case, superflat bounds are not a problem, we just + -- get the null string in accordance with normal Ada slice rules. + + String (Source.Data (Low .. High))) + with Pre => Low - 1 <= Super_Length (Source) + and then High <= Super_Length (Source); function Super_Slice (Source : Super_String; Low : Positive; - High : Natural) return Super_String; + High : Natural) return Super_String + with + Pre => + Low - 1 <= Super_Length (Source) and then High <= Super_Length (Source), + Post => Super_Slice'Result.Max_Length = Source.Max_Length + and then + Super_To_String (Super_Slice'Result) = + Super_Slice (Source, Low, High), + Global => null; procedure Super_Slice (Source : Super_String; Target : out Super_String; Low : Positive; - High : Natural); + High : Natural) + with + Pre => Source.Max_Length = Target.Max_Length + and then Low - 1 <= Super_Length (Source) + and then High <= Super_Length (Source), + Post => Super_To_String (Target) = Super_Slice (Source, Low, High), + Global => null; function "=" (Left : Super_String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Pre => Left.Max_Length = Right.Max_Length, + Post => "="'Result = (Super_To_String (Left) = Super_To_String (Right)), + Global => null; function Equal (Left : Super_String; @@ -175,59 +691,111 @@ package Ada.Strings.Superbounded is function Equal (Left : Super_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Post => Equal'Result = (Super_To_String (Left) = Right), + Global => null; function Equal (Left : String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Post => Equal'Result = (Left = Super_To_String (Right)), + Global => null; function Less (Left : Super_String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Pre => Left.Max_Length = Right.Max_Length, + Post => + Less'Result = (Super_To_String (Left) < Super_To_String (Right)), + Global => null; function Less (Left : Super_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Post => Less'Result = (Super_To_String (Left) < Right), + Global => null; function Less (Left : String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Post => Less'Result = (Left < Super_To_String (Right)), + Global => null; function Less_Or_Equal (Left : Super_String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Pre => Left.Max_Length = Right.Max_Length, + Post => + Less_Or_Equal'Result = + (Super_To_String (Left) <= Super_To_String (Right)), + Global => null; function Less_Or_Equal (Left : Super_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Post => Less_Or_Equal'Result = (Super_To_String (Left) <= Right), + Global => null; function Less_Or_Equal (Left : String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Post => Less_Or_Equal'Result = (Left <= Super_To_String (Right)), + Global => null; function Greater (Left : Super_String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Pre => Left.Max_Length = Right.Max_Length, + Post => + Greater'Result = (Super_To_String (Left) > Super_To_String (Right)), + Global => null; function Greater (Left : Super_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Post => Greater'Result = (Super_To_String (Left) > Right), + Global => null; function Greater (Left : String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Post => Greater'Result = (Left > Super_To_String (Right)), + Global => null; function Greater_Or_Equal (Left : Super_String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Pre => Left.Max_Length = Right.Max_Length, + Post => + Greater_Or_Equal'Result = + (Super_To_String (Left) >= Super_To_String (Right)), + Global => null; function Greater_Or_Equal (Left : Super_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Post => Greater_Or_Equal'Result = (Super_To_String (Left) >= Right), + Global => null; function Greater_Or_Equal (Left : String; - Right : Super_String) return Boolean; + Right : Super_String) return Boolean + with + Post => Greater_Or_Equal'Result = (Left >= Super_To_String (Right)), + Global => null; ---------------------- -- Search Functions -- @@ -237,63 +805,449 @@ package Ada.Strings.Superbounded is (Source : Super_String; Pattern : String; Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => Pattern'Length > 0, + Post => Super_Index'Result <= Super_Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Super_Length (Source) = 0 + => + Super_Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Super_Length (Source) > 0 + and then + (for some J in 1 .. Super_Length (Source) - (Pattern'Length - 1) => + Search.Match (Super_To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Super_Index'Result in + 1 .. Super_Length (Source) - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (Super_To_String (Source), Pattern, Mapping, Super_Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if (if Going = Forward + then J <= Super_Index'Result - 1 + else J - 1 in Super_Index'Result + .. Super_Length (Source) - Pattern'Length) + then not (Search.Match + (Super_To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Super_Index'Result = 0), + Global => null; function Super_Index (Source : Super_String; Pattern : String; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length /= 0 and then Mapping /= null, + Post => Super_Index'Result <= Super_Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Super_Length (Source) = 0 + => + Super_Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Super_Length (Source) > 0 + and then + (for some J in 1 .. Super_Length (Source) - (Pattern'Length - 1) => + Search.Match (Super_To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Super_Index'Result in + 1 .. Super_Length (Source) - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (Super_To_String (Source), Pattern, Mapping, Super_Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if (if Going = Forward + then J <= Super_Index'Result - 1 + else J - 1 in Super_Index'Result + .. Super_Length (Source) - Pattern'Length) + then not (Search.Match + (Super_To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Super_Index'Result = 0), + Global => null; function Super_Index (Source : Super_String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Post => Super_Index'Result <= Super_Length (Source), + Contract_Cases => + + -- If no character of Source satisfies the property Test on Set, + -- then 0 is returned. + + ((for all C of Super_To_String (Source) => + (Test = Inside) /= Maps.Is_In (C, Set)) + => + Super_Index'Result = 0, + + -- Otherwise, an index in the range of Source is returned + + others + => + -- The result is in the range of Source + + Super_Index'Result in 1 .. Super_Length (Source) + + -- The character at the returned index satisfies the property + -- Test on Set. + + and then + (Test = Inside) = + Maps.Is_In (Super_Element (Source, Super_Index'Result), Set) + + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if J /= Super_Index'Result + and then (J < Super_Index'Result) = (Going = Forward) + then (Test = Inside) + /= Maps.Is_In (Super_Element (Source, J), Set)))), + Global => null; function Super_Index (Source : Super_String; Pattern : String; From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => + (if Super_Length (Source) /= 0 then From <= Super_Length (Source)) + and then Pattern'Length /= 0, + Post => Super_Index'Result <= Super_Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Super_Length (Source) = 0 + => + Super_Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Super_Length (Source) > 0 + and then + (for some J in + (if Going = Forward then From else 1) + .. (if Going = Forward then Super_Length (Source) else From) + - (Pattern'Length - 1) => + Search.Match (Super_To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Super_Index'Result in + (if Going = Forward then From else 1) + .. (if Going = Forward then Super_Length (Source) else From) + - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (Super_To_String (Source), Pattern, Mapping, Super_Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if (if Going = Forward + then J in From .. Super_Index'Result - 1 + else J - 1 in Super_Index'Result + .. From - Pattern'Length) + then not (Search.Match + (Super_To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Super_Index'Result = 0), + Global => null; function Super_Index (Source : Super_String; Pattern : String; From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => + (if Super_Length (Source) /= 0 then From <= Super_Length (Source)) + and then Pattern'Length /= 0 + and then Mapping /= null, + Post => Super_Index'Result <= Super_Length (Source), + Contract_Cases => + + -- If Source is the empty string, then 0 is returned + + (Super_Length (Source) = 0 + => + Super_Index'Result = 0, + + -- If some slice of Source matches Pattern, then a valid index is + -- returned. + + Super_Length (Source) > 0 + and then + (for some J in + (if Going = Forward then From else 1) + .. (if Going = Forward then Super_Length (Source) else From) + - (Pattern'Length - 1) => + Search.Match (Super_To_String (Source), Pattern, Mapping, J)) + => + -- The result is in the considered range of Source + + Super_Index'Result in + (if Going = Forward then From else 1) + .. (if Going = Forward then Super_Length (Source) else From) + - (Pattern'Length - 1) + + -- The slice beginning at the returned index matches Pattern + + and then Search.Match + (Super_To_String (Source), Pattern, Mapping, Super_Index'Result) + + -- The result is the smallest or largest index which satisfies + -- the matching, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if (if Going = Forward + then J in From .. Super_Index'Result - 1 + else J - 1 in Super_Index'Result + .. From - Pattern'Length) + then not (Search.Match + (Super_To_String (Source), Pattern, Mapping, J)))), + + -- Otherwise, 0 is returned + + others + => + Super_Index'Result = 0), + Global => null; function Super_Index (Source : Super_String; Set : Maps.Character_Set; From : Positive; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => + (if Super_Length (Source) /= 0 then From <= Super_Length (Source)), + Post => Super_Index'Result <= Super_Length (Source), + Contract_Cases => + + -- If Source is the empty string, or no character of the considered + -- slice of Source satisfies the property Test on Set, then 0 is + -- returned. + + (Super_Length (Source) = 0 + or else + (for all J in 1 .. Super_Length (Source) => + (if J = From or else (J > From) = (Going = Forward) then + (Test = Inside) /= + Maps.Is_In (Super_Element (Source, J), Set))) + => + Super_Index'Result = 0, + + -- Otherwise, an index in the considered range of Source is returned + + others + => + -- The result is in the considered range of Source + + Super_Index'Result in 1 .. Super_Length (Source) + and then + (Super_Index'Result = From + or else (Super_Index'Result > From) = (Going = Forward)) + + -- The character at the returned index satisfies the property + -- Test on Set. + + and then + (Test = Inside) = + Maps.Is_In (Super_Element (Source, Super_Index'Result), Set) + + -- The result is the smallest or largest index which satisfies + -- the property, respectively when Going = Forward and Going = + -- Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if J /= Super_Index'Result + and then (J < Super_Index'Result) = (Going = Forward) + and then (J = From + or else (J > From) = (Going = Forward)) + then (Test = Inside) + /= Maps.Is_In (Super_Element (Source, J), Set)))), + Global => null; function Super_Index_Non_Blank (Source : Super_String; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Post => Super_Index_Non_Blank'Result <= Super_Length (Source), + Contract_Cases => + + -- If all characters of Source are Space characters, then 0 is + -- returned. + + ((for all C of Super_To_String (Source) => C = ' ') + => + Super_Index_Non_Blank'Result = 0, + + -- Otherwise, an index in the range of Source is returned + + others + => + -- The result is in the range of Source + + Super_Index_Non_Blank'Result in 1 .. Super_Length (Source) + + -- The character at the returned index is not a Space character + + and then + Super_Element (Source, Super_Index_Non_Blank'Result) /= ' ' + + -- The result is the smallest or largest index which is not a + -- Space character, respectively when Going = Forward and Going + -- = Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if J /= Super_Index_Non_Blank'Result + and then + (J < Super_Index_Non_Blank'Result) = (Going = Forward) + then Super_Element (Source, J) = ' '))), + Global => null; function Super_Index_Non_Blank (Source : Super_String; From : Positive; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => + (if Super_Length (Source) /= 0 then From <= Super_Length (Source)), + Post => Super_Index_Non_Blank'Result <= Super_Length (Source), + Contract_Cases => + + -- If Source is the empty string, or all characters of the + -- considered slice of Source are Space characters, then 0 + -- is returned. + + (Super_Length (Source) = 0 + or else + (for all J in 1 .. Super_Length (Source) => + (if J = From or else (J > From) = (Going = Forward) then + Super_Element (Source, J) = ' ')) + => + Super_Index_Non_Blank'Result = 0, + + -- Otherwise, an index in the considered range of Source is returned + + others + => + -- The result is in the considered range of Source + + Super_Index_Non_Blank'Result in 1 .. Super_Length (Source) + and then + (Super_Index_Non_Blank'Result = From + or else + (Super_Index_Non_Blank'Result > From) = (Going = Forward)) + + -- The character at the returned index is not a Space character + + and then + Super_Element (Source, Super_Index_Non_Blank'Result) /= ' ' + + -- The result is the smallest or largest index which isn't a + -- Space character, respectively when Going = Forward and Going + -- = Backward. + + and then + (for all J in 1 .. Super_Length (Source) => + (if J /= Super_Index_Non_Blank'Result + and then + (J < Super_Index_Non_Blank'Result) = (Going = Forward) + and then (J = From + or else (J > From) = (Going = Forward)) + then Super_Element (Source, J) = ' '))), + Global => null; function Super_Count (Source : Super_String; Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => Pattern'Length /= 0, + Global => null; function Super_Count (Source : Super_String; Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length /= 0 and then Mapping /= null, + Global => null; function Super_Count (Source : Super_String; - Set : Maps.Character_Set) return Natural; + Set : Maps.Character_Set) return Natural + with + Global => null; procedure Super_Find_Token (Source : Super_String; @@ -301,14 +1255,112 @@ package Ada.Strings.Superbounded is From : Positive; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Pre => + (if Super_Length (Source) /= 0 then From <= Super_Length (Source)), + Contract_Cases => + + -- If Source is the empty string, or if no character of the + -- considered slice of Source satisfies the property Test on + -- Set, then First is set to From and Last is set to 0. + + (Super_Length (Source) = 0 + or else + (for all J in From .. Super_Length (Source) => + (Test = Inside) /= Maps.Is_In (Super_Element (Source, J), Set)) + => + First = From and then Last = 0, + + -- Otherwise, First and Last are set to valid indexes + + others + => + -- First and Last are in the considered range of Source + + First in From .. Super_Length (Source) + and then Last in First .. Super_Length (Source) + + -- No character between From and First satisfies the property + -- Test on Set. + + and then + (for all J in From .. First - 1 => + (Test = Inside) /= + Maps.Is_In (Super_Element (Source, J), Set)) + + -- All characters between First and Last satisfy the property + -- Test on Set. + + and then + (for all J in First .. Last => + (Test = Inside) = + Maps.Is_In (Super_Element (Source, J), Set)) + + -- If Last is not Source'Last, then the character at position + -- Last + 1 does not satify the property Test on Set. + + and then + (if Last < Super_Length (Source) + then + (Test = Inside) /= + Maps.Is_In (Super_Element (Source, Last + 1), Set))), + Global => null; procedure Super_Find_Token (Source : Super_String; Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Contract_Cases => + + -- If Source is the empty string, or if no character of the considered + -- slice of Source satisfies the property Test on Set, then First is + -- set to 1 and Last is set to 0. + + (Super_Length (Source) = 0 + or else + (for all J in 1 .. Super_Length (Source) => + (Test = Inside) /= Maps.Is_In (Super_Element (Source, J), Set)) + => + First = 1 and then Last = 0, + + -- Otherwise, First and Last are set to valid indexes + + others + => + -- First and Last are in the considered range of Source + + First in 1 .. Super_Length (Source) + and then Last in First .. Super_Length (Source) + + -- No character between 1 and First satisfies the property Test on + -- Set. + + and then + (for all J in 1 .. First - 1 => + (Test = Inside) /= + Maps.Is_In (Super_Element (Source, J), Set)) + + -- All characters between First and Last satisfy the property + -- Test on Set. + + and then + (for all J in First .. Last => + (Test = Inside) = + Maps.Is_In (Super_Element (Source, J), Set)) + + -- If Last is not Source'Last, then the character at position + -- Last + 1 does not satify the property Test on Set. + + and then + (if Last < Super_Length (Source) + then + (Test = Inside) /= + Maps.Is_In (Super_Element (Source, Last + 1), Set))), + Global => null; ------------------------------------ -- String Translation Subprograms -- @@ -316,19 +1368,51 @@ package Ada.Strings.Superbounded is function Super_Translate (Source : Super_String; - Mapping : Maps.Character_Mapping) return Super_String; + Mapping : Maps.Character_Mapping) return Super_String + with + Post => Super_Translate'Result.Max_Length = Source.Max_Length + and then Super_Length (Super_Translate'Result) = Super_Length (Source) + and then + (for all K in 1 .. Super_Length (Source) => + Super_Element (Super_Translate'Result, K) = + Ada.Strings.Maps.Value (Mapping, Super_Element (Source, K))), + Global => null; procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping); + Mapping : Maps.Character_Mapping) + with + Post => Super_Length (Source) = Super_Length (Source'Old) + and then + (for all K in 1 .. Super_Length (Source) => + Super_Element (Source, K) = + Ada.Strings.Maps.Value (Mapping, Super_Element (Source'Old, K))), + Global => null; function Super_Translate (Source : Super_String; - Mapping : Maps.Character_Mapping_Function) return Super_String; + Mapping : Maps.Character_Mapping_Function) return Super_String + with + Pre => Mapping /= null, + Post => Super_Translate'Result.Max_Length = Source.Max_Length + and then Super_Length (Super_Translate'Result) = Super_Length (Source) + and then + (for all K in 1 .. Super_Length (Source) => + Super_Element (Super_Translate'Result, K) = + Mapping (Super_Element (Source, K))), + Global => null; procedure Super_Translate (Source : in out Super_String; - Mapping : Maps.Character_Mapping_Function); + Mapping : Maps.Character_Mapping_Function) + with + Pre => Mapping /= null, + Post => Super_Length (Source) = Super_Length (Source'Old) + and then + (for all K in 1 .. Super_Length (Source) => + Super_Element (Source, K) = + Mapping (Super_Element (Source'Old, K))), + Global => null; --------------------------------------- -- String Transformation Subprograms -- @@ -339,48 +1423,756 @@ package Ada.Strings.Superbounded is Low : Positive; High : Natural; By : String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + Low - 1 <= Super_Length (Source) + and then + (if Drop = Error + then (if High >= Low + then Low - 1 + <= Source.Max_Length - By'Length + - Integer'Max (Super_Length (Source) - High, 0) + else Super_Length (Source) <= + Source.Max_Length - By'Length)), + Post => + Super_Replace_Slice'Result.Max_Length = Source.Max_Length, + Contract_Cases => + (Low - 1 <= Source.Max_Length - By'Length - Integer'Max + (Super_Length (Source) - Integer'Max (High, Low - 1), 0) + => + -- Total length is lower than Max_Length: nothing is dropped + + -- Note that if High < Low, the insertion is done before Low, so in + -- all cases the starting position of the slice of Source remaining + -- after the replaced Slice is Integer'Max (High + 1, Low). + + Super_Length (Super_Replace_Slice'Result) = + Low - 1 + By'Length + Integer'Max + (Super_Length (Source) - Integer'Max (High, Low - 1), 0) + and then + String'(Super_Slice (Super_Replace_Slice'Result, 1, Low - 1)) = + Super_Slice (Source, 1, Low - 1) + and then + Super_Slice (Super_Replace_Slice'Result, + Low, Low - 1 + By'Length) = By + and then + (if Integer'Max (High, Low - 1) < Super_Length (Source) then + String'(Super_Slice (Super_Replace_Slice'Result, + Low + By'Length, + Super_Length (Super_Replace_Slice'Result))) = + Super_Slice (Source, + Integer'Max (High + 1, Low), Super_Length (Source))), + + Low - 1 > Source.Max_Length - By'Length - Integer'Max + (Super_Length (Source) - Integer'Max (High, Low - 1), 0) + and then Drop = Left + => + -- Final_Super_Slice is the length of the slice of Source remaining + -- after the replaced part. + (declare + Final_Super_Slice : constant Natural := + Integer'Max + (Super_Length (Source) - Integer'Max (High, Low - 1), 0); + begin + -- The result is of maximal length and ends by the last + -- Final_Super_Slice characters of Source. + + Super_Length (Super_Replace_Slice'Result) = Source.Max_Length + and then + (if Final_Super_Slice > 0 then + String'(Super_Slice (Super_Replace_Slice'Result, + Source.Max_Length - Final_Super_Slice + 1, + Source.Max_Length)) = + Super_Slice (Source, + Integer'Max (High + 1, Low), Super_Length (Source))) + + -- Depending on when we reach Max_Length, either the first + -- part of Source is fully dropped and By is partly dropped, + -- or By is fully added and the first part of Source is partly + -- dropped. + + and then + (if Source.Max_Length - Final_Super_Slice - By'Length <= 0 then + + -- The first (possibly zero) characters of By are dropped + + (if Final_Super_Slice < Source.Max_Length then + Super_Slice (Super_Replace_Slice'Result, + 1, Source.Max_Length - Final_Super_Slice) = + By (By'Last - Source.Max_Length + Final_Super_Slice + + 1 + .. By'Last)) + + else -- By is added to the result + + Super_Slice (Super_Replace_Slice'Result, + Source.Max_Length - Final_Super_Slice - By'Length + 1, + Source.Max_Length - Final_Super_Slice) = + By + + -- The first characters of Source (1 .. Low - 1) are + -- dropped. + + and then + String'(Super_Slice (Super_Replace_Slice'Result, 1, + Source.Max_Length - Final_Super_Slice - By'Length)) = + Super_Slice (Source, + Low - Source.Max_Length + + Final_Super_Slice + By'Length, + Low - 1))), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first Low - 1 + -- characters of Source. + + Super_Length (Super_Replace_Slice'Result) = Source.Max_Length + and then + String'(Super_Slice (Super_Replace_Slice'Result, 1, Low - 1)) = + Super_Slice (Source, 1, Low - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and By is partly dropped, or By + -- is fully added and the last part of Source is partly dropped. + + and then + (if Low - 1 >= Source.Max_Length - By'Length then + + -- The last characters of By are dropped + + Super_Slice (Super_Replace_Slice'Result, + Low, Source.Max_Length) = + By (By'First .. Source.Max_Length - Low + By'First) + + else -- By is fully added + + Super_Slice (Super_Replace_Slice'Result, + Low, Low + By'Length - 1) = By + + -- Then Source starting from Natural'Max (High + 1, Low) + -- is added but the last characters are dropped. + + and then + String'(Super_Slice (Super_Replace_Slice'Result, + Low + By'Length, Source.Max_Length)) = + Super_Slice (Source, Integer'Max (High + 1, Low), + Integer'Max (High + 1, Low) + + (Source.Max_Length - Low - By'Length)))), + Global => null; procedure Super_Replace_Slice (Source : in out Super_String; Low : Positive; High : Natural; By : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => + Low - 1 <= Super_Length (Source) + and then + (if Drop = Error + then (if High >= Low + then Low - 1 + <= Source.Max_Length - By'Length + - Natural'Max (Super_Length (Source) - High, 0) + else Super_Length (Source) <= + Source.Max_Length - By'Length)), + Contract_Cases => + (Low - 1 <= Source.Max_Length - By'Length - Integer'Max + (Super_Length (Source) - Integer'Max (High, Low - 1), 0) + => + -- Total length is lower than Max_Length: nothing is dropped + + -- Note that if High < Low, the insertion is done before Low, so in + -- all cases the starting position of the slice of Source remaining + -- after the replaced Slice is Integer'Max (High + 1, Low). + + Super_Length (Source) = Low - 1 + By'Length + Integer'Max + (Super_Length (Source'Old) - Integer'Max (High, Low - 1), 0) + and then + String'(Super_Slice (Source, 1, Low - 1)) = + Super_Slice (Source'Old, 1, Low - 1) + and then Super_Slice (Source, Low, Low - 1 + By'Length) = By + and then + (if Integer'Max (High, Low - 1) < Super_Length (Source'Old) then + String'(Super_Slice (Source, + Low + By'Length, Super_Length (Source))) = + Super_Slice (Source'Old, + Integer'Max (High + 1, Low), + Super_Length (Source'Old))), + + Low - 1 > Source.Max_Length - By'Length - Integer'Max + (Super_Length (Source) - Integer'Max (High, Low - 1), 0) + and then Drop = Left + => + -- Final_Super_Slice is the length of the slice of Source remaining + -- after the replaced part. + (declare + Final_Super_Slice : constant Natural := + Integer'Max (0, + Super_Length (Source'Old) - Integer'Max (High, Low - 1)); + begin + -- The result is of maximal length and ends by the last + -- Final_Super_Slice characters of Source. + + Super_Length (Source) = Source.Max_Length + and then + (if Final_Super_Slice > 0 then + String'(Super_Slice (Source, + Source.Max_Length - Final_Super_Slice + 1, + Source.Max_Length)) = + Super_Slice (Source'Old, + Integer'Max (High + 1, Low), + Super_Length (Source'Old))) + + -- Depending on when we reach Max_Length, either the first + -- part of Source is fully dropped and By is partly dropped, + -- or By is fully added and the first part of Source is partly + -- dropped. + + and then + (if Source.Max_Length - Final_Super_Slice - By'Length <= 0 + then + -- The first characters of By are dropped + + (if Final_Super_Slice < Source.Max_Length then + Super_Slice (Source, + 1, Source.Max_Length - Final_Super_Slice) = + By (By'Last - Source.Max_Length + Final_Super_Slice + + 1 + .. By'Last)) + + else -- By is added to the result + + Super_Slice (Source, + Source.Max_Length - Final_Super_Slice - By'Length + 1, + Source.Max_Length - Final_Super_Slice) = By + + -- The first characters of Source (1 .. Low - 1) are + -- dropped. + + and then + String'(Super_Slice (Source, 1, + Source.Max_Length - Final_Super_Slice - By'Length)) = + Super_Slice (Source'Old, + Low - Source.Max_Length + Final_Super_Slice + + By'Length, + Low - 1))), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first Low - 1 + -- characters of Source. + + Super_Length (Source) = Source.Max_Length + and then + String'(Super_Slice (Source, 1, Low - 1)) = + Super_Slice (Source'Old, 1, Low - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and By is partly dropped, or By + -- is fully added and the last part of Source is partly dropped. + + and then + (if Low - 1 >= Source.Max_Length - By'Length then + + -- The last characters of By are dropped + + Super_Slice (Source, Low, Source.Max_Length) = + By (By'First .. Source.Max_Length - Low + By'First) + + else -- By is fully added + + Super_Slice (Source, Low, Low + By'Length - 1) = By + + -- Then Source starting from Natural'Max (High + 1, Low) + -- is added but the last characters are dropped. + + and then + String'(Super_Slice (Source, + Low + By'Length, Source.Max_Length)) = + Super_Slice (Source'Old, Integer'Max (High + 1, Low), + Integer'Max (High + 1, Low) + + (Source.Max_Length - Low - By'Length)))), + Global => null; function Super_Insert (Source : Super_String; Before : Positive; New_Item : String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + Before - 1 <= Super_Length (Source) + and then + (if New_Item'Length > Source.Max_Length - Super_Length (Source) + then Drop /= Error), + Post => Super_Insert'Result.Max_Length = Source.Max_Length, + Contract_Cases => + (Super_Length (Source) <= Source.Max_Length - New_Item'Length + => + -- Total length is lower than Max_Length: nothing is dropped + + Super_Length (Super_Insert'Result) = + Super_Length (Source) + New_Item'Length + and then + String'(Super_Slice (Super_Insert'Result, 1, Before - 1)) = + Super_Slice (Source, 1, Before - 1) + and then + Super_Slice (Super_Insert'Result, + Before, Before - 1 + New_Item'Length) = + New_Item + and then + (if Before <= Super_Length (Source) then + String'(Super_Slice (Super_Insert'Result, + Before + New_Item'Length, + Super_Length (Super_Insert'Result))) = + Super_Slice (Source, Before, Super_Length (Source))), + + Super_Length (Source) > Source.Max_Length - New_Item'Length + and then Drop = Left + => + -- The result is of maximal length and ends by the last characters + -- of Source. + + Super_Length (Super_Insert'Result) = Source.Max_Length + and then + (if Before <= Super_Length (Source) then + String'(Super_Slice (Super_Insert'Result, + Source.Max_Length - Super_Length (Source) + Before, + Source.Max_Length)) = + Super_Slice (Source, Before, Super_Length (Source))) + + -- Depending on when we reach Max_Length, either the first part + -- of Source is fully dropped and New_Item is partly dropped, or + -- New_Item is fully added and the first part of Source is partly + -- dropped. + + and then + (if Source.Max_Length - Super_Length (Source) - 1 + Before + < New_Item'Length + then + -- The first characters of New_Item are dropped + + (if Super_Length (Source) - Before + 1 < Source.Max_Length + then + Super_Slice (Super_Insert'Result, 1, + Source.Max_Length - Super_Length (Source) - 1 + Before) = + New_Item + (New_Item'Last - Source.Max_Length + + Super_Length (Source) - Before + 2 + .. New_Item'Last)) + + else -- New_Item is added to the result + + Super_Slice (Super_Insert'Result, + Source.Max_Length - Super_Length (Source) - New_Item'Length + + Before, + Source.Max_Length - Super_Length (Source) - 1 + Before) = + New_Item + + -- The first characters of Source (1 .. Before - 1) are + -- dropped. + + and then + String'(Super_Slice (Super_Insert'Result, + 1, Source.Max_Length - Super_Length (Source) + - New_Item'Length - 1 + Before)) = + Super_Slice (Source, + Super_Length (Source) - Source.Max_Length + + New_Item'Length + 1, + Before - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Super_Length (Super_Insert'Result) = Source.Max_Length + and then + String'(Super_Slice (Super_Insert'Result, 1, Before - 1)) = + Super_Slice (Source, 1, Before - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and New_Item is partly dropped, or + -- New_Item is fully added and the last part of Source is partly + -- dropped. + + and then + (if Before - 1 >= Source.Max_Length - New_Item'Length then + + -- The last characters of New_Item are dropped + + Super_Slice (Super_Insert'Result, Before, Source.Max_Length) = + New_Item (New_Item'First + .. Source.Max_Length - Before + New_Item'First) + + else -- New_Item is fully added + + Super_Slice (Super_Insert'Result, + Before, Before + New_Item'Length - 1) = + New_Item + + -- Then Source starting from Before is added but the + -- last characters are dropped. + + and then + String'(Super_Slice (Super_Insert'Result, + Before + New_Item'Length, Source.Max_Length)) = + Super_Slice (Source, + Before, Source.Max_Length - New_Item'Length))), + Global => null; procedure Super_Insert (Source : in out Super_String; Before : Positive; New_Item : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => + Before - 1 <= Super_Length (Source) + and then + (if New_Item'Length > Source.Max_Length - Super_Length (Source) + then Drop /= Error), + Contract_Cases => + (Super_Length (Source) <= Source.Max_Length - New_Item'Length + => + -- Total length is lower than Max_Length: nothing is dropped + + Super_Length (Source) = Super_Length (Source'Old) + New_Item'Length + and then + String'(Super_Slice (Source, 1, Before - 1)) = + Super_Slice (Source'Old, 1, Before - 1) + and then + Super_Slice (Source, Before, Before - 1 + New_Item'Length) = + New_Item + and then + (if Before <= Super_Length (Source'Old) then + String'(Super_Slice (Source, + Before + New_Item'Length, Super_Length (Source))) = + Super_Slice (Source'Old, + Before, Super_Length (Source'Old))), + + Super_Length (Source) > Source.Max_Length - New_Item'Length + and then Drop = Left + => + -- The result is of maximal length and ends by the last characters + -- of Source. + + Super_Length (Source) = Source.Max_Length + and then + (if Before <= Super_Length (Source'Old) then + String'(Super_Slice (Source, + Source.Max_Length - Super_Length (Source'Old) + Before, + Source.Max_Length)) = + Super_Slice (Source'Old, + Before, Super_Length (Source'Old))) + + -- Depending on when we reach Max_Length, either the first part + -- of Source is fully dropped and New_Item is partly dropped, or + -- New_Item is fully added and the first part of Source is partly + -- dropped. + + and then + (if Source.Max_Length - Super_Length (Source'Old) - 1 + Before + < New_Item'Length + then + -- The first characters of New_Item are dropped + + (if Super_Length (Source'Old) - Before + 1 < Source.Max_Length + then + Super_Slice (Source, + 1, Source.Max_Length - Super_Length (Source'Old) + - 1 + Before) = + New_Item + (New_Item'Last - Source.Max_Length + + Super_Length (Source'Old) - Before + 2 + .. New_Item'Last)) + + else -- New_Item is added to the result + + Super_Slice (Source, + Source.Max_Length - Super_Length (Source'Old) + - New_Item'Length + Before, + Source.Max_Length - Super_Length (Source'Old) - 1 + Before) + = New_Item + + -- The first characters of Source (1 .. Before - 1) are + -- dropped. + + and then + String'(Super_Slice (Source, 1, + Source.Max_Length - Super_Length (Source'Old) + - New_Item'Length - 1 + Before)) = + Super_Slice (Source'Old, + Super_Length (Source'Old) + - Source.Max_Length + New_Item'Length + 1, + Before - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Super_Length (Source) = Source.Max_Length + and then + String'(Super_Slice (Source, 1, Before - 1)) = + Super_Slice (Source'Old, 1, Before - 1) + + -- Depending on when we reach Max_Length, either the last part + -- of Source is fully dropped and New_Item is partly dropped, or + -- New_Item is fully added and the last part of Source is partly + -- dropped. + + and then + (if Before - 1 >= Source.Max_Length - New_Item'Length then + + -- The last characters of New_Item are dropped + + Super_Slice (Source, Before, Source.Max_Length) = + New_Item (New_Item'First + .. Source.Max_Length - Before + New_Item'First) + + else -- New_Item is fully added + + Super_Slice (Source, Before, Before + New_Item'Length - 1) = + New_Item + + -- Then Source starting from Before is added but the + -- last characters are dropped. + + and then + String'(Super_Slice (Source, + Before + New_Item'Length, Source.Max_Length)) = + Super_Slice (Source'Old, + Before, Source.Max_Length - New_Item'Length))), + Global => null; function Super_Overwrite (Source : Super_String; Position : Positive; New_Item : String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + Position - 1 <= Super_Length (Source) + and then (if New_Item'Length > Source.Max_Length - (Position - 1) + then Drop /= Error), + Post => Super_Overwrite'Result.Max_Length = Source.Max_Length, + Contract_Cases => + (Position - 1 <= Source.Max_Length - New_Item'Length + => + -- The length is unchanged, unless New_Item overwrites further than + -- the end of Source. In this contract case, we suppose New_Item + -- doesn't overwrite further than Max_Length. + + Super_Length (Super_Overwrite'Result) = + Integer'Max (Super_Length (Source), Position - 1 + New_Item'Length) + and then + String'(Super_Slice (Super_Overwrite'Result, 1, Position - 1)) = + Super_Slice (Source, 1, Position - 1) + and then Super_Slice (Super_Overwrite'Result, + Position, Position - 1 + New_Item'Length) = + New_Item + and then + (if Position - 1 + New_Item'Length < Super_Length (Source) then + + -- There are some unchanged characters of Source remaining + -- after New_Item. + + String'(Super_Slice (Super_Overwrite'Result, + Position + New_Item'Length, Super_Length (Source))) = + Super_Slice (Source, + Position + New_Item'Length, Super_Length (Source))), + + Position - 1 > Source.Max_Length - New_Item'Length and then Drop = Left + => + Super_Length (Super_Overwrite'Result) = Source.Max_Length + + -- If a part of the result has to be dropped, it means New_Item is + -- overwriting further than the end of Source. Thus the result is + -- necessarily ending by New_Item. However, we don't know whether + -- New_Item covers all Max_Length characters or some characters of + -- Source are remaining at the left. + + and then + (if New_Item'Length > Source.Max_Length then + + -- New_Item covers all Max_Length characters + + Super_To_String (Super_Overwrite'Result) = + New_Item + (New_Item'Last - Source.Max_Length + 1 .. New_Item'Last) + else + -- New_Item fully appears at the end + + Super_Slice (Super_Overwrite'Result, + Source.Max_Length - New_Item'Length + 1, + Source.Max_Length) = + New_Item + + -- The left of Source is cut + + and then + String'(Super_Slice (Super_Overwrite'Result, + 1, Source.Max_Length - New_Item'Length)) = + Super_Slice (Source, + Position - Source.Max_Length + New_Item'Length, + Position - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Super_Length (Super_Overwrite'Result) = Source.Max_Length + and then + String'(Super_Slice (Super_Overwrite'Result, 1, Position - 1)) = + Super_Slice (Source, 1, Position - 1) + + -- Then New_Item is written until Max_Length + + and then Super_Slice (Super_Overwrite'Result, + Position, Source.Max_Length) = + New_Item (New_Item'First + .. Source.Max_Length - Position + New_Item'First)), + Global => null; procedure Super_Overwrite (Source : in out Super_String; Position : Positive; New_Item : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => + Position - 1 <= Super_Length (Source) + and then (if New_Item'Length > Source.Max_Length - (Position - 1) + then Drop /= Error), + Contract_Cases => + (Position - 1 <= Source.Max_Length - New_Item'Length + => + -- The length is unchanged, unless New_Item overwrites further than + -- the end of Source. In this contract case, we suppose New_Item + -- doesn't overwrite further than Max_Length. + + Super_Length (Source) = Integer'Max + (Super_Length (Source'Old), Position - 1 + New_Item'Length) + and then + String'(Super_Slice (Source, 1, Position - 1)) = + Super_Slice (Source'Old, 1, Position - 1) + and then Super_Slice (Source, + Position, Position - 1 + New_Item'Length) = + New_Item + and then + (if Position - 1 + New_Item'Length < Super_Length (Source'Old) + then + -- There are some unchanged characters of Source remaining + -- after New_Item. + + String'(Super_Slice (Source, + Position + New_Item'Length, Super_Length (Source'Old))) = + Super_Slice (Source'Old, + Position + New_Item'Length, Super_Length (Source'Old))), + + Position - 1 > Source.Max_Length - New_Item'Length and then Drop = Left + => + Super_Length (Source) = Source.Max_Length + + -- If a part of the result has to be dropped, it means New_Item is + -- overwriting further than the end of Source. Thus the result is + -- necessarily ending by New_Item. However, we don't know whether + -- New_Item covers all Max_Length characters or some characters of + -- Source are remaining at the left. + + and then + (if New_Item'Length > Source.Max_Length then + + -- New_Item covers all Max_Length characters + + Super_To_String (Source) = + New_Item + (New_Item'Last - Source.Max_Length + 1 .. New_Item'Last) + else + -- New_Item fully appears at the end + + Super_Slice (Source, + Source.Max_Length - New_Item'Length + 1, + Source.Max_Length) = + New_Item + + -- The left of Source is cut + + and then + String'(Super_Slice (Source, + 1, Source.Max_Length - New_Item'Length)) = + Super_Slice (Source'Old, + Position - Source.Max_Length + New_Item'Length, + Position - 1)), + + others -- Drop = Right + => + -- The result is of maximal length and starts by the first + -- characters of Source. + + Super_Length (Source) = Source.Max_Length + and then + String'(Super_Slice (Source, 1, Position - 1)) = + Super_Slice (Source'Old, 1, Position - 1) + + -- New_Item is written until Max_Length + + and then Super_Slice (Source, Position, Source.Max_Length) = + New_Item (New_Item'First + .. Source.Max_Length - Position + New_Item'First)), + Global => null; function Super_Delete (Source : Super_String; From : Positive; - Through : Natural) return Super_String; + Through : Natural) return Super_String + with + Pre => + (if Through >= From then From - 1 <= Super_Length (Source)), + Post => Super_Delete'Result.Max_Length = Source.Max_Length, + Contract_Cases => + (Through >= From => + Super_Length (Super_Delete'Result) = + From - 1 + Natural'Max (Super_Length (Source) - Through, 0) + and then + String'(Super_Slice (Super_Delete'Result, 1, From - 1)) = + Super_Slice (Source, 1, From - 1) + and then + (if Through < Super_Length (Source) then + String'(Super_Slice (Super_Delete'Result, + From, Super_Length (Super_Delete'Result))) = + Super_Slice (Source, Through + 1, Super_Length (Source))), + others => + Super_Delete'Result = Source), + Global => null; procedure Super_Delete (Source : in out Super_String; From : Positive; - Through : Natural); + Through : Natural) + with + Pre => + (if Through >= From then From - 1 <= Super_Length (Source)), + Contract_Cases => + (Through >= From => + Super_Length (Source) = + From - 1 + Natural'Max (Super_Length (Source'Old) - Through, 0) + and then + String'(Super_Slice (Source, 1, From - 1)) = + Super_Slice (Source'Old, 1, From - 1) + and then + (if Through < Super_Length (Source) then + String'(Super_Slice (Source, From, Super_Length (Source))) = + Super_Slice (Source'Old, + Through + 1, Super_Length (Source'Old))), + others => + Source = Source'Old), + Global => null; --------------------------------- -- String Selector Subprograms -- @@ -388,45 +2180,376 @@ package Ada.Strings.Superbounded is function Super_Trim (Source : Super_String; - Side : Trim_End) return Super_String; + Side : Trim_End) return Super_String + with + Post => Super_Trim'Result.Max_Length = Source.Max_Length, + Contract_Cases => + + -- If all characters in Source are Space, the returned string is empty + + ((for all C of Super_To_String (Source) => C = ' ') + => + Super_Length (Super_Trim'Result) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + (if Side = Right then 1 + else Super_Index_Non_Blank (Source, Forward)); + High : constant Positive := + (if Side = Left then Super_Length (Source) + else Super_Index_Non_Blank (Source, Backward)); + begin + Super_To_String (Super_Trim'Result) = + Super_Slice (Source, Low, High))), + Global => null; procedure Super_Trim (Source : in out Super_String; - Side : Trim_End); + Side : Trim_End) + with + Contract_Cases => + + -- If all characters in Source are Space, the returned string is empty + + ((for all C of Super_To_String (Source) => C = ' ') + => + Super_Length (Source) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + (if Side = Right then 1 + else Super_Index_Non_Blank (Source'Old, Forward)); + High : constant Positive := + (if Side = Left then Super_Length (Source'Old) + else Super_Index_Non_Blank (Source'Old, Backward)); + begin + Super_To_String (Source) = Super_Slice (Source'Old, Low, High))), + Global => null; function Super_Trim (Source : Super_String; Left : Maps.Character_Set; - Right : Maps.Character_Set) return Super_String; + Right : Maps.Character_Set) return Super_String + with + Post => Super_Trim'Result.Max_Length = Source.Max_Length, + Contract_Cases => + + -- If all characters in Source are contained in one of the sets Left or + -- Right, then the returned string is empty. + + ((for all C of Super_To_String (Source) => Maps.Is_In (C, Left)) + or else + (for all C of Super_To_String (Source) => Maps.Is_In (C, Right)) + => + Super_Length (Super_Trim'Result) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + Super_Index (Source, Left, Outside, Forward); + High : constant Positive := + Super_Index (Source, Right, Outside, Backward); + begin + Super_To_String (Super_Trim'Result) = + Super_Slice (Source, Low, High))), + Global => null; procedure Super_Trim (Source : in out Super_String; Left : Maps.Character_Set; - Right : Maps.Character_Set); + Right : Maps.Character_Set) + with + Contract_Cases => + + -- If all characters in Source are contained in one of the sets Left or + -- Right, then the returned string is empty. + + ((for all C of Super_To_String (Source) => Maps.Is_In (C, Left)) + or else + (for all C of Super_To_String (Source) => Maps.Is_In (C, Right)) + => + Super_Length (Source) = 0, + + -- Otherwise, the returned string is a slice of Source + + others + => + (declare + Low : constant Positive := + Super_Index (Source'Old, Left, Outside, Forward); + High : constant Positive := + Super_Index (Source'Old, Right, Outside, Backward); + begin + Super_To_String (Source) = Super_Slice (Source'Old, Low, High))), + Global => null; function Super_Head (Source : Super_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => (if Count > Source.Max_Length then Drop /= Error), + Post => Super_Head'Result.Max_Length = Source.Max_Length, + Contract_Cases => + (Count <= Super_Length (Source) + => + -- Source is cut + + Super_To_String (Super_Head'Result) = Super_Slice (Source, 1, Count), + Count > Super_Length (Source) and then Count <= Source.Max_Length + => + -- Source is followed by Pad characters + + Super_Length (Super_Head'Result) = Count + and then + Super_Slice (Super_Head'Result, 1, Super_Length (Source)) = + Super_To_String (Source) + and then + String'(Super_Slice (Super_Head'Result, + Super_Length (Source) + 1, Count)) = + (1 .. Count - Super_Length (Source) => Pad), + Count > Source.Max_Length and then Drop = Right + => + -- Source is followed by Pad characters + + Super_Length (Super_Head'Result) = Source.Max_Length + and then + Super_Slice (Super_Head'Result, 1, Super_Length (Source)) = + Super_To_String (Source) + and then + String'(Super_Slice (Super_Head'Result, + Super_Length (Source) + 1, Source.Max_Length)) = + (1 .. Source.Max_Length - Super_Length (Source) => Pad), + Count - Super_Length (Source) > Source.Max_Length and then Drop = Left + => + -- Source is fully dropped on the left + + Super_To_String (Super_Head'Result) = + (1 .. Source.Max_Length => Pad), + others + => + -- Source is partly dropped on the left + + Super_Length (Super_Head'Result) = Source.Max_Length + and then + String'(Super_Slice (Super_Head'Result, + 1, Source.Max_Length - Count + Super_Length (Source))) = + Super_Slice (Source, + Count - Source.Max_Length + 1, Super_Length (Source)) + and then + String'(Super_Slice (Super_Head'Result, + Source.Max_Length - Count + Super_Length (Source) + 1, + Source.Max_Length)) = + (1 .. Count - Super_Length (Source) => Pad)), + Global => null; procedure Super_Head (Source : in out Super_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => (if Count > Source.Max_Length then Drop /= Error), + Contract_Cases => + (Count <= Super_Length (Source) + => + -- Source is cut + + Super_To_String (Source) = Super_Slice (Source'Old, 1, Count), + Count > Super_Length (Source) and then Count <= Source.Max_Length + => + -- Source is followed by Pad characters + + Super_Length (Source) = Count + and then + Super_Slice (Source, 1, Super_Length (Source'Old)) = + Super_To_String (Source'Old) + and then + String'(Super_Slice (Source, + Super_Length (Source'Old) + 1, Count)) = + (1 .. Count - Super_Length (Source'Old) => Pad), + Count > Source.Max_Length and then Drop = Right + => + -- Source is followed by Pad characters + + Super_Length (Source) = Source.Max_Length + and then + Super_Slice (Source, 1, Super_Length (Source'Old)) = + Super_To_String (Source'Old) + and then + String'(Super_Slice (Source, + Super_Length (Source'Old) + 1, Source.Max_Length)) = + (1 .. Source.Max_Length - Super_Length (Source'Old) => Pad), + Count - Super_Length (Source) > Source.Max_Length and then Drop = Left + => + -- Source is fully dropped on the left + + Super_To_String (Source) = (1 .. Source.Max_Length => Pad), + others + => + -- Source is partly dropped on the left + + Super_Length (Source) = Source.Max_Length + and then + String'(Super_Slice (Source, + 1, Source.Max_Length - Count + Super_Length (Source'Old))) = + Super_Slice (Source'Old, + Count - Source.Max_Length + 1, Super_Length (Source'Old)) + and then + String'(Super_Slice (Source, + Source.Max_Length - Count + Super_Length (Source'Old) + 1, + Source.Max_Length)) = + (1 .. Count - Super_Length (Source'Old) => Pad)), + Global => null; function Super_Tail (Source : Super_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => (if Count > Source.Max_Length then Drop /= Error), + Post => Super_Tail'Result.Max_Length = Source.Max_Length, + Contract_Cases => + (Count < Super_Length (Source) + => + -- Source is cut + + (if Count > 0 then + Super_To_String (Super_Tail'Result) = + Super_Slice (Source, + Super_Length (Source) - Count + 1, Super_Length (Source)) + else Super_Length (Super_Tail'Result) = 0), + Count >= Super_Length (Source) and then Count < Source.Max_Length + => + -- Source is preceded by Pad characters + + Super_Length (Super_Tail'Result) = Count + and then + String'(Super_Slice (Super_Tail'Result, + 1, Count - Super_Length (Source))) = + (1 .. Count - Super_Length (Source) => Pad) + and then + Super_Slice (Super_Tail'Result, + Count - Super_Length (Source) + 1, Count) = + Super_To_String (Source), + Count >= Source.Max_Length and then Drop = Left + => + -- Source is preceded by Pad characters + + Super_Length (Super_Tail'Result) = Source.Max_Length + and then + String'(Super_Slice (Super_Tail'Result, + 1, Source.Max_Length - Super_Length (Source))) = + (1 .. Source.Max_Length - Super_Length (Source) => Pad) + and then + (if Super_Length (Source) > 0 then + Super_Slice (Super_Tail'Result, + Source.Max_Length - Super_Length (Source) + 1, + Source.Max_Length) = + Super_To_String (Source)), + Count - Super_Length (Source) >= Source.Max_Length + and then Drop /= Left + => + -- Source is fully dropped on the right + + Super_To_String (Super_Tail'Result) = + (1 .. Source.Max_Length => Pad), + others + => + -- Source is partly dropped on the right + + Super_Length (Super_Tail'Result) = Source.Max_Length + and then + String'(Super_Slice (Super_Tail'Result, + 1, Count - Super_Length (Source))) = + (1 .. Count - Super_Length (Source) => Pad) + and then + String'(Super_Slice (Super_Tail'Result, + Count - Super_Length (Source) + 1, Source.Max_Length)) = + Super_Slice (Source, + 1, Source.Max_Length - Count + Super_Length (Source))), + Global => null; procedure Super_Tail (Source : in out Super_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => (if Count > Source.Max_Length then Drop /= Error), + Contract_Cases => + (Count < Super_Length (Source) + => + -- Source is cut + + (if Count > 0 then + Super_To_String (Source) = + Super_Slice (Source'Old, + Super_Length (Source'Old) - Count + 1, + Super_Length (Source'Old)) + else Super_Length (Source) = 0), + Count >= Super_Length (Source) and then Count < Source.Max_Length + => + -- Source is preceded by Pad characters + + Super_Length (Source) = Count + and then + String'(Super_Slice (Source, + 1, Count - Super_Length (Source'Old))) = + (1 .. Count - Super_Length (Source'Old) => Pad) + and then + Super_Slice (Source, + Count - Super_Length (Source'Old) + 1, Count) = + Super_To_String (Source'Old), + Count >= Source.Max_Length and then Drop = Left + => + -- Source is preceded by Pad characters + + Super_Length (Source) = Source.Max_Length + and then + String'(Super_Slice (Source, + 1, Source.Max_Length - Super_Length (Source'Old))) = + (1 .. Source.Max_Length - Super_Length (Source'Old) => Pad) + and then + (if Super_Length (Source'Old) > 0 then + Super_Slice (Source, + Source.Max_Length - Super_Length (Source'Old) + 1, + Source.Max_Length) = + Super_To_String (Source'Old)), + Count - Super_Length (Source) >= Source.Max_Length + and then Drop /= Left + => + -- Source is fully dropped on the right + + Super_To_String (Source) = (1 .. Source.Max_Length => Pad), + others + => + -- Source is partly dropped on the right + + Super_Length (Source) = Source.Max_Length + and then + String'(Super_Slice (Source, + 1, Count - Super_Length (Source'Old))) = + (1 .. Count - Super_Length (Source'Old) => Pad) + and then + String'(Super_Slice (Source, + Count - Super_Length (Source'Old) + 1, Source.Max_Length)) = + Super_Slice (Source'Old, + 1, Source.Max_Length - Count + Super_Length (Source'Old))), + Global => null; ------------------------------------ -- String Constructor Subprograms -- @@ -439,37 +2562,135 @@ package Ada.Strings.Superbounded is function Times (Left : Natural; Right : Character; - Max_Length : Positive) return Super_String; + Max_Length : Positive) return Super_String + with + Pre => Left <= Max_Length, + Post => Times'Result.Max_Length = Max_Length + and then Super_To_String (Times'Result) = (1 .. Left => Right), + Global => null; -- Note the additional parameter Max_Length function Times (Left : Natural; Right : String; - Max_Length : Positive) return Super_String; + Max_Length : Positive) return Super_String + with + Pre => (if Left /= 0 then Right'Length <= Max_Length / Left), + Post => Times'Result.Max_Length = Max_Length + and then Super_Length (Times'Result) = Left * Right'Length + and then + (if Right'Length > 0 then + (for all K in 1 .. Left * Right'Length => + Super_Element (Times'Result, K) = + Right (Right'First + (K - 1) mod Right'Length))), + Global => null; -- Note the additional parameter Max_Length function Times (Left : Natural; - Right : Super_String) return Super_String; + Right : Super_String) return Super_String + with + Pre => + (if Left /= 0 then Super_Length (Right) <= Right.Max_Length / Left), + Post => Times'Result.Max_Length = Right.Max_Length + and then Super_Length (Times'Result) = Left * Super_Length (Right) + and then + (if Super_Length (Right) > 0 then + (for all K in 1 .. Left * Super_Length (Right) => + Super_Element (Times'Result, K) = + Super_Element (Right, 1 + (K - 1) mod Super_Length (Right)))), + Global => null; function Super_Replicate (Count : Natural; Item : Character; Drop : Truncation := Error; - Max_Length : Positive) return Super_String; + Max_Length : Positive) return Super_String + with + Pre => (if Count > Max_Length then Drop /= Error), + Post => Super_Replicate'Result.Max_Length = Max_Length + and then Super_To_String (Super_Replicate'Result) = + (1 .. Natural'Min (Max_Length, Count) => Item), + Global => null; -- Note the additional parameter Max_Length function Super_Replicate (Count : Natural; Item : String; Drop : Truncation := Error; - Max_Length : Positive) return Super_String; + Max_Length : Positive) return Super_String + with + Pre => + (if Count /= 0 and then Item'Length > Max_Length / Count + then Drop /= Error), + Post => Super_Replicate'Result.Max_Length = Max_Length, + Contract_Cases => + (Count = 0 or else Item'Length <= Max_Length / Count + => + Super_Length (Super_Replicate'Result) = Count * Item'Length + and then + (if Item'Length > 0 then + (for all K in 1 .. Count * Item'Length => + Super_Element (Super_Replicate'Result, K) = + Item (Item'First + (K - 1) mod Item'Length))), + Count /= 0 + and then Item'Length > Max_Length / Count + and then Drop = Right + => + Super_Length (Super_Replicate'Result) = Max_Length + and then + (for all K in 1 .. Max_Length => + Super_Element (Super_Replicate'Result, K) = + Item (Item'First + (K - 1) mod Item'Length)), + others -- Drop = Left + => + Super_Length (Super_Replicate'Result) = Max_Length + and then + (for all K in 1 .. Max_Length => + Super_Element (Super_Replicate'Result, K) = + Item (Item'Last - (Max_Length - K) mod Item'Length))), + Global => null; -- Note the additional parameter Max_Length function Super_Replicate (Count : Natural; Item : Super_String; - Drop : Truncation := Error) return Super_String; + Drop : Truncation := Error) return Super_String + with + Pre => + (if Count /= 0 + and then Super_Length (Item) > Item.Max_Length / Count + then Drop /= Error), + Post => Super_Replicate'Result.Max_Length = Item.Max_Length, + Contract_Cases => + ((if Count /= 0 then Super_Length (Item) <= Item.Max_Length / Count) + => + Super_Length (Super_Replicate'Result) = Count * Super_Length (Item) + and then + (if Super_Length (Item) > 0 then + (for all K in 1 .. Count * Super_Length (Item) => + Super_Element (Super_Replicate'Result, K) = + Super_Element (Item, + 1 + (K - 1) mod Super_Length (Item)))), + Count /= 0 + and then Super_Length (Item) > Item.Max_Length / Count + and then Drop = Right + => + Super_Length (Super_Replicate'Result) = Item.Max_Length + and then + (for all K in 1 .. Item.Max_Length => + Super_Element (Super_Replicate'Result, K) = + Super_Element (Item, 1 + (K - 1) mod Super_Length (Item))), + others -- Drop = Left + => + Super_Length (Super_Replicate'Result) = Item.Max_Length + and then + (for all K in 1 .. Item.Max_Length => + Super_Element (Super_Replicate'Result, K) = + Super_Element (Item, + Super_Length (Item) + - (Item.Max_Length - K) mod Super_Length (Item)))), + Global => null; private -- Pragma Inline declarations diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads index 13c7612..b3050fd 100644 --- a/gcc/ada/libgnat/a-strunb.ads +++ b/gcc/ada/libgnat/a-strunb.ads @@ -53,11 +53,13 @@ private with Ada.Strings.Text_Buffers; -- and selector operations are provided. package Ada.Strings.Unbounded with + SPARK_Mode, Initial_Condition => Length (Null_Unbounded_String) = 0 is pragma Preelaborate; - type Unbounded_String is private; + type Unbounded_String is private with + Default_Initial_Condition => Length (Unbounded_String) = 0; pragma Preelaborable_Initialization (Unbounded_String); Null_Unbounded_String : constant Unbounded_String; @@ -73,7 +75,7 @@ is -- Provides a (nonprivate) access type for explicit processing of -- unbounded-length strings. - procedure Free (X : in out String_Access); + procedure Free (X : in out String_Access) with SPARK_Mode => Off; -- Performs an unchecked deallocation of an object of type String_Access -------------------------------------------------------- @@ -732,6 +734,8 @@ is -- strings applied to the string represented by Source's original value. private + pragma SPARK_Mode (Off); -- Controlled types are not in SPARK + pragma Inline (Length); package AF renames Ada.Finalization; diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads index 2091bde..2cf6780 100644 --- a/gcc/ada/libgnat/a-strunb__shared.ads +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -85,7 +85,8 @@ package Ada.Strings.Unbounded with is pragma Preelaborate; - type Unbounded_String is private; + type Unbounded_String is private with + Default_Initial_Condition => Length (Unbounded_String) = 0; pragma Preelaborable_Initialization (Unbounded_String); Null_Unbounded_String : constant Unbounded_String; diff --git a/gcc/ada/libgnat/a-textio.adb b/gcc/ada/libgnat/a-textio.adb index 717f529..8667360 100644 --- a/gcc/ada/libgnat/a-textio.adb +++ b/gcc/ada/libgnat/a-textio.adb @@ -44,6 +44,7 @@ pragma Elaborate_All (System.File_IO); -- Needed because of calls to Chain_File in package body elaboration package body Ada.Text_IO with + SPARK_Mode => Off, Refined_State => (File_System => (Standard_In, Standard_Out, Standard_Err, diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads index a06a35c..f94c92d 100644 --- a/gcc/ada/libgnat/a-textio.ads +++ b/gcc/ada/libgnat/a-textio.ads @@ -56,8 +56,9 @@ with System.File_Control_Block; with System.WCh_Con; package Ada.Text_IO with - Abstract_State => (File_System), - Initializes => (File_System), + SPARK_Mode, + Abstract_State => File_System, + Initializes => File_System, Initial_Condition => Line_Length = 0 and Page_Length = 0 is pragma Elaborate_Body; @@ -547,6 +548,7 @@ is Layout_Error : exception renames IO_Exceptions.Layout_Error; private + pragma SPARK_Mode (Off); -- The following procedures have a File_Type formal of mode IN OUT because -- they may close the original file. The Close operation may raise an diff --git a/gcc/ada/libgnat/a-zchhan.adb b/gcc/ada/libgnat/a-zchhan.adb index 3f2a91b..61405f7 100644 --- a/gcc/ada/libgnat/a-zchhan.adb +++ b/gcc/ada/libgnat/a-zchhan.adb @@ -33,6 +33,15 @@ with Ada.Wide_Wide_Characters.Unicode; use Ada.Wide_Wide_Characters.Unicode; package body Ada.Wide_Wide_Characters.Handling is + --------------------------- + -- Character_Set_Version -- + --------------------------- + + function Character_Set_Version return String is + begin + return "Unicode 4.0"; + end Character_Set_Version; + --------------------- -- Is_Alphanumeric -- --------------------- @@ -42,6 +51,13 @@ package body Ada.Wide_Wide_Characters.Handling is return Is_Letter (Item) or else Is_Digit (Item); end Is_Alphanumeric; + -------------- + -- Is_Basic -- + -------------- + + function Is_Basic (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Basic; + ---------------- -- Is_Control -- ---------------- @@ -191,4 +207,22 @@ package body Ada.Wide_Wide_Characters.Handling is return Result; end To_Upper; + -------------- + -- To_Basic -- + -------------- + + function To_Basic (Item : Wide_Wide_Character) return Wide_Wide_Character + renames Ada.Wide_Wide_Characters.Unicode.To_Basic; + + function To_Basic (Item : Wide_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Basic (Item (J)); + end loop; + + return Result; + end To_Basic; + end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/libgnat/a-zchhan.ads b/gcc/ada/libgnat/a-zchhan.ads index 74fab2a..6ebd1a8 100644 --- a/gcc/ada/libgnat/a-zchhan.ads +++ b/gcc/ada/libgnat/a-zchhan.ads @@ -15,10 +15,12 @@ package Ada.Wide_Wide_Characters.Handling is pragma Pure; - -- This package is clearly intended to be Pure, by analogy with the - -- base Ada.Characters.Handling package. The version in the RM does - -- not yet have this pragma, but that is a clear omission. This will - -- be fixed in a future version of AI05-0266-1. + + function Character_Set_Version return String; + pragma Inline (Character_Set_Version); + -- Returns an implementation-defined identifier that identifies the version + -- of the character set standard that is used for categorizing characters + -- by the implementation. For GNAT this is "Unicode v.v". function Is_Control (Item : Wide_Wide_Character) return Boolean; pragma Inline (Is_Control); @@ -42,6 +44,12 @@ package Ada.Wide_Wide_Characters.Handling is -- Returns True if the Wide_Wide_Character designated by Item is -- categorized as letter_uppercase, otherwise returns false. + function Is_Basic (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Basic); + -- Returns True if the Wide_Wide_Character designated by Item has no + -- Decomposition Mapping in the code charts of ISO/IEC 10646:2017, + -- otherwise returns False. + function Is_Digit (Item : Wide_Wide_Character) return Boolean; pragma Inline (Is_Digit); -- Returns True if the Wide_Wide_Character designated by Item is @@ -135,4 +143,17 @@ package Ada.Wide_Wide_Characters.Handling is -- designated by Item. The result is the null Wide_Wide_String if the value -- of the formal parameter is the null Wide_Wide_String. + function To_Basic (Item : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Basic); + -- Returns the Wide_Wide_Character whose code point is given + -- by the first value of its Decomposition Mapping in the code charts + -- of ISO/IEC 10646:2017 if any, returns Item otherwise. + + function To_Basic (Item : Wide_Wide_String) return Wide_Wide_String; + -- Returns the result of applying the To_Basic conversion to each + -- Wide_Wide_Character element of the Wide_Wide_String designated by Item. + -- The result is the null Wide_Wide_String if the value of the formal + -- parameter is the null Wide_Wide_String. The lower bound of the result + -- Wide_Wide_String is 1. + end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/libgnat/a-zchuni.adb b/gcc/ada/libgnat/a-zchuni.adb index 2bbe584..3c6e720 100644 --- a/gcc/ada/libgnat/a-zchuni.adb +++ b/gcc/ada/libgnat/a-zchuni.adb @@ -43,6 +43,15 @@ package body Ada.Wide_Wide_Characters.Unicode is end Get_Category; -------------- + -- Is_Basic -- + -------------- + + function Is_Basic (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Basic (Wide_Wide_Character'Pos (U)); + end Is_Basic; + + -------------- -- Is_Digit -- -------------- @@ -158,6 +167,16 @@ package body Ada.Wide_Wide_Characters.Unicode is return G.Is_UTF_32_Space (G.Category (C)); end Is_Space; + -------------- + -- To_Basic -- + -------------- + + function To_Basic (U : Wide_Wide_Character) return Wide_Wide_Character is + begin + return Wide_Wide_Character'Val + (G.UTF_32_To_Basic (Wide_Wide_Character'Pos (U))); + end To_Basic; + ------------------- -- To_Lower_Case -- ------------------- diff --git a/gcc/ada/libgnat/a-zchuni.ads b/gcc/ada/libgnat/a-zchuni.ads index 51f7c92..0030fd1 100644 --- a/gcc/ada/libgnat/a-zchuni.ads +++ b/gcc/ada/libgnat/a-zchuni.ads @@ -177,6 +177,18 @@ package Ada.Wide_Wide_Characters.Unicode is -- in the list of categories above. This means that these characters can -- be included in character and string literals. + function Is_Basic (U : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Basic); + -- Returns True if the Wide_Wide_Character designated by Item has no + -- Decomposition Mapping in the code charts of ISO/IEC 10646:2017, + -- otherwise returns False. + + function To_Basic (U : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Basic); + -- Returns the Wide_Wide_Character whose code point is given by the first + -- value of its Decomposition Mapping in the code charts of + -- ISO/IEC 10646:2017 if any, returns Item otherwise. + -- The following function is used to fold to upper case, as required by -- the Ada 2005 standard rules for identifier case folding. Two -- identifiers are equivalent if they are identical after folding all diff --git a/gcc/ada/libgnat/g-forstr.adb b/gcc/ada/libgnat/g-forstr.adb index 64c4cb6..04539be 100644 --- a/gcc/ada/libgnat/g-forstr.adb +++ b/gcc/ada/libgnat/g-forstr.adb @@ -420,11 +420,11 @@ package body GNAT.Formatted_String is -- Zero padding if required and possible - if F_Spec.Left_Justify = False + if not F_Spec.Left_Justify and then F_Spec.Zero_Pad and then F_Spec.Width > Len + Value'First - S then - Append (Res, String'((F_Spec.Width - Len + Value'First - S) * '0')); + Append (Res, String'((F_Spec.Width - (Len + Value'First - S)) * '0')); end if; -- Add the value now @@ -519,7 +519,7 @@ package body GNAT.Formatted_String is J := J + 1; end loop; - if F (J) /= '%' or else J = F'Last then + if J >= F'Last or else F (J) /= '%' then raise Format_Error with "no format specifier found for parameter" & Positive'Image (Format.D.Current); end if; diff --git a/gcc/ada/libgnat/i-vxwork.ads b/gcc/ada/libgnat/i-vxwork.ads index c5686bb..0ba1e6e 100644 --- a/gcc/ada/libgnat/i-vxwork.ads +++ b/gcc/ada/libgnat/i-vxwork.ads @@ -133,6 +133,9 @@ package Interfaces.VxWorks is OK : constant STATUS := 0; ERROR : constant STATUS := -1; + type BOOL is new int; + -- Equivalent of the C type BOOL + type VOIDFUNCPTR is access procedure (parameter : System.Address); type Interrupt_Vector is new System.Address; type Exception_Vector is new System.Address; @@ -145,9 +148,9 @@ package Interfaces.VxWorks is -- The routine generates a wrapper around the user handler to save and -- restore context - function intContext return int; - -- Binding to the C routine intContext. This function returns 1 only if the - -- current execution state is in interrupt context. + function intContext return BOOL; + -- Binding to the C routine intContext. This function returns 1 (TRUE) + -- only if the current execution state is in interrupt context. function intVecGet (Vector : Interrupt_Vector) return VOIDFUNCPTR; diff --git a/gcc/ada/libgnat/i-vxwork__x86.ads b/gcc/ada/libgnat/i-vxwork__x86.ads index ed9bb42..659167f 100644 --- a/gcc/ada/libgnat/i-vxwork__x86.ads +++ b/gcc/ada/libgnat/i-vxwork__x86.ads @@ -128,6 +128,9 @@ package Interfaces.VxWorks is OK : constant STATUS := 0; ERROR : constant STATUS := -1; + type BOOL is new int; + -- Equivalent of the C type BOOL + type VOIDFUNCPTR is access procedure (parameter : System.Address); type Interrupt_Vector is new System.Address; type Exception_Vector is new System.Address; @@ -140,9 +143,9 @@ package Interfaces.VxWorks is -- The routine generates a wrapper around the user handler to save and -- restore context - function intContext return int; - -- Binding to the C routine intContext. This function returns 1 only if the - -- current execution state is in interrupt context. + function intContext return BOOL; + -- Binding to the C routine intContext. This function returns 1 (TRUE) + -- only if the current execution state is in interrupt context. function intVecGet (Vector : Interrupt_Vector) return VOIDFUNCPTR; diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb index e622fec..b34ac04 100644 --- a/gcc/ada/libgnat/memtrack.adb +++ b/gcc/ada/libgnat/memtrack.adb @@ -69,10 +69,13 @@ pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb"); with Ada.Exceptions; +with GNAT.IO; + with System.Soft_Links; with System.Traceback; with System.Traceback_Entries; -with GNAT.IO; +with System.CRTL; +with System.OS_Lib; with System.OS_Primitives; package body System.Memory is @@ -93,30 +96,14 @@ package body System.Memory is (Ptr : System.Address; Size : size_t) return System.Address; pragma Import (C, c_realloc, "realloc"); - subtype File_Ptr is System.Address; - - function fopen (Path : String; Mode : String) return File_Ptr; - pragma Import (C, fopen); - - procedure OS_Exit (Status : Integer); - pragma Import (C, OS_Exit, "__gnat_os_exit"); - pragma No_Return (OS_Exit); - In_Child_After_Fork : Integer; pragma Import (C, In_Child_After_Fork, "__gnat_in_child_after_fork"); - procedure fwrite - (Ptr : System.Address; - Size : size_t; - Nmemb : size_t; - Stream : File_Ptr); - pragma Import (C, fwrite); + subtype File_Ptr is CRTL.FILEs; - procedure fputc (C : Integer; Stream : File_Ptr); - pragma Import (C, fputc); + procedure Write (Ptr : System.Address; Size : size_t); - procedure fclose (Stream : File_Ptr); - pragma Import (C, fclose); + procedure Putc (Char : Character); procedure Finalize; pragma Export (C, Finalize, "__gnat_finalize"); @@ -210,20 +197,17 @@ package body System.Memory is Timestamp := System.OS_Primitives.Clock; Call_Chain (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); - fputc (Character'Pos ('A'), Gmemfile); - fwrite (Result'Address, Address_Size, 1, Gmemfile); - fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); + Putc ('A'); + Write (Result'Address, Address_Size); + Write (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements); + Write (Timestamp'Address, Duration'Max_Size_In_Storage_Elements); + Write (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements); for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop declare Ptr : System.Address := PC_For (Tracebk (J)); begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + Write (Ptr'Address, Address_Size); end; end loop; @@ -246,8 +230,8 @@ package body System.Memory is procedure Finalize is begin - if not Needs_Init then - fclose (Gmemfile); + if not Needs_Init and then CRTL.fclose (Gmemfile) /= 0 then + Put_Line ("gmem close error: " & OS_Lib.Errno_Message); end if; end Finalize; @@ -275,18 +259,16 @@ package body System.Memory is Call_Chain (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); Timestamp := System.OS_Primitives.Clock; - fputc (Character'Pos ('D'), Gmemfile); - fwrite (Addr'Address, Address_Size, 1, Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); + Putc ('D'); + Write (Addr'Address, Address_Size); + Write (Timestamp'Address, Duration'Max_Size_In_Storage_Elements); + Write (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements); for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop declare Ptr : System.Address := PC_For (Tracebk (J)); begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + Write (Ptr'Address, Address_Size); end; end loop; @@ -304,29 +286,41 @@ package body System.Memory is procedure Gmem_Initialize is Timestamp : aliased Duration; - + File_Mode : constant String := "wb" & ASCII.NUL; begin if Needs_Init then Needs_Init := False; System.OS_Primitives.Initialize; Timestamp := System.OS_Primitives.Clock; - Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL); + Gmemfile := CRTL.fopen (Gmemfname'Address, File_Mode'Address); if Gmemfile = System.Null_Address then Put_Line ("Couldn't open gnatmem log file for writing"); - OS_Exit (255); + OS_Lib.OS_Exit (255); end if; declare S : constant String := "GMEM DUMP" & ASCII.LF; begin - fwrite (S'Address, S'Length, 1, Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, - 1, Gmemfile); + Write (S'Address, S'Length); + Write (Timestamp'Address, Duration'Max_Size_In_Storage_Elements); end; end if; end Gmem_Initialize; + ---------- + -- Putc -- + ---------- + + procedure Putc (Char : Character) is + C : constant Integer := Character'Pos (Char); + + begin + if CRTL.fputc (C, Gmemfile) /= C then + Put_Line ("gmem fputc error: " & OS_Lib.Errno_Message); + end if; + end Putc; + ------------- -- Realloc -- ------------- @@ -360,18 +354,16 @@ package body System.Memory is Call_Chain (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); Timestamp := System.OS_Primitives.Clock; - fputc (Character'Pos ('D'), Gmemfile); - fwrite (Addr'Address, Address_Size, 1, Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); + Putc ('D'); + Write (Addr'Address, Address_Size); + Write (Timestamp'Address, Duration'Max_Size_In_Storage_Elements); + Write (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements); for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop declare Ptr : System.Address := PC_For (Tracebk (J)); begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + Write (Ptr'Address, Address_Size); end; end loop; @@ -381,20 +373,17 @@ package body System.Memory is -- Log allocation call using the same backtrace - fputc (Character'Pos ('A'), Gmemfile); - fwrite (Result'Address, Address_Size, 1, Gmemfile); - fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); + Putc ('A'); + Write (Result'Address, Address_Size); + Write (Size'Address, size_t'Max_Size_In_Storage_Elements); + Write (Timestamp'Address, Duration'Max_Size_In_Storage_Elements); + Write (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements); for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop declare Ptr : System.Address := PC_For (Tracebk (J)); begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + Write (Ptr'Address, Address_Size); end; end loop; @@ -411,4 +400,22 @@ package body System.Memory is return Result; end Realloc; + ----------- + -- Write -- + ----------- + + procedure Write (Ptr : System.Address; Size : size_t) is + function fwrite + (buffer : System.Address; + size : size_t; + count : size_t; + stream : File_Ptr) return size_t; + pragma Import (C, fwrite); + + begin + if fwrite (Ptr, Size, 1, Gmemfile) /= 1 then + Put_Line ("gmem fwrite error: " & OS_Lib.Errno_Message); + end if; + end Write; + end System.Memory; diff --git a/gcc/ada/libgnat/s-arit128.ads b/gcc/ada/libgnat/s-arit128.ads index 6213cfb..fa6fedc 100644 --- a/gcc/ada/libgnat/s-arit128.ads +++ b/gcc/ada/libgnat/s-arit128.ads @@ -81,4 +81,11 @@ package System.Arith_128 is -- then Q is the rounded quotient. The remainder R is not affected by the -- setting of the Round flag. +private + -- Make it callable from strub contexts. + -- There is a matching setting in trans.c, + -- for calls issued by Gigi. + pragma Machine_Attribute (Multiply_With_Ovflo_Check128, + "strub", "callable"); + end System.Arith_128; diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads index c9141f5..68d2149 100644 --- a/gcc/ada/libgnat/s-arit64.ads +++ b/gcc/ada/libgnat/s-arit64.ads @@ -93,4 +93,11 @@ package System.Arith_64 is Round : Boolean) renames Double_Divide64; -- Renamed procedure to preserve compatibility with earlier versions +private + -- Make it callable from strub contexts. + -- There is a matching setting in trans.c, + -- for calls issued by Gigi. + pragma Machine_Attribute (Multiply_With_Ovflo_Check64, + "strub", "callable"); + end System.Arith_64; diff --git a/gcc/ada/libgnat/s-imenne.adb b/gcc/ada/libgnat/s-imenne.adb deleted file mode 100644 index 4ca7a12..0000000 --- a/gcc/ada/libgnat/s-imenne.adb +++ /dev/null @@ -1,170 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M _ N E W -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2021, 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. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; - -package body System.Img_Enum_New is - - ------------------------- - -- Image_Enumeration_8 -- - ------------------------- - - procedure Image_Enumeration_8 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - 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 Names_Index; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - 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; - end Image_Enumeration_8; - - -------------------------- - -- Image_Enumeration_16 -- - -------------------------- - - procedure Image_Enumeration_16 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - 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 Names_Index; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - 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; - end Image_Enumeration_16; - - -------------------------- - -- Image_Enumeration_32 -- - -------------------------- - - procedure Image_Enumeration_32 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - 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 Names_Index; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - 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; - end Image_Enumeration_32; - -end System.Img_Enum_New; diff --git a/gcc/ada/libgnat/s-imenne.ads b/gcc/ada/libgnat/s-imenne.ads deleted file mode 100644 index eba31c2..0000000 --- a/gcc/ada/libgnat/s-imenne.ads +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M _ N E W -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2021, 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. -- --- -- ------------------------------------------------------------------------------- - --- Enumeration_Type'Image for all enumeration types except those in package --- Standard (where we have no opportunity to build image tables), and in --- package System (where it is too early to start building image tables). --- Special routines exist for the enumeration types in these packages. - --- Note: this is an obsolete package replaced by instantiations of the generic --- package System.Image_N. The reason we maintain this package is that when --- bootstrapping with an old compiler, the old compiler will search for this --- unit, expecting to find these functions. The new compiler will search for --- procedures in the instances of System.Image_N instead. - -pragma Compiler_Unit_Warning; - -package System.Img_Enum_New is - pragma Pure; - - procedure Image_Enumeration_8 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Used to compute Enum'Image (Str) where Enum is some enumeration type - -- other than those defined in package Standard. Names is a string with - -- a lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address of - -- an array of type array (0 .. N) of Natural_8, where N is the number of - -- enumeration literals in the type. The Indexes values are the starting - -- subscript of each enumeration literal, indexed by Pos values, with an - -- extra entry at the end containing Names'Length + 1. The reason that - -- Indexes is passed by address is that the actual type is created on the - -- fly by the expander. The desired 'Image value is stored in S (1 .. P) - -- and P is set on return. The caller guarantees that S is long enough to - -- hold the result and that the lower bound is 1. - - procedure Image_Enumeration_16 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Identical to Set_Image_Enumeration_8 except that it handles types using - -- array (0 .. Num) of Natural_16 for the Indexes table. - - procedure Image_Enumeration_32 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Identical to Set_Image_Enumeration_8 except that it handles types using - -- array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Img_Enum_New; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads index 2e0b42c..e6e3efc 100644 --- a/gcc/ada/libgnat/s-imglli.ads +++ b/gcc/ada/libgnat/s-imglli.ads @@ -30,8 +30,8 @@ ------------------------------------------------------------------------------ -- This package contains the routines for supporting the Image attribute for --- signed integer types larger Integer, and also for conversion operations --- required in Text_IO.Integer_IO for such types. +-- signed integer types larger than Integer, and also for conversion +-- operations required in Text_IO.Integer_IO for such types. with System.Image_I; diff --git a/gcc/ada/libgnat/s-parame__vxworks.ads b/gcc/ada/libgnat/s-parame__vxworks.ads index 11b408b..b22d858 100644 --- a/gcc/ada/libgnat/s-parame__vxworks.ads +++ b/gcc/ada/libgnat/s-parame__vxworks.ads @@ -108,11 +108,11 @@ package System.Parameters is -- Select the appropriate time_t_bits for the VSB in use, then rebuild -- the runtime using instructions in adainclude/libada.gpr. - time_t_bits : constant := Long_Integer'Size; + -- time_t_bits : constant := Long_Integer'Size; -- Number of bits in type time_t for SR0650 and before and SR0660 with -- non-default configuration. - -- time_t_bits : constant := Long_Long_Integer'Size; + time_t_bits : constant := Long_Long_Integer'Size; -- Number of bits in type time_t for SR0660 with default configuration. ---------------------------------------------- diff --git a/gcc/ada/libgnat/s-regpat.adb b/gcc/ada/libgnat/s-regpat.adb index 7e33067..b40f682 100644 --- a/gcc/ada/libgnat/s-regpat.adb +++ b/gcc/ada/libgnat/s-regpat.adb @@ -3463,18 +3463,58 @@ package body System.Regpat is end; elsif Self.First /= ASCII.NUL then - -- We know what char it must start with + -- We know what char (modulo casing) it must start with - declare - Next_Try : Natural := Index (First_In_Data, Self.First); + if (Self.Flags and Case_Insensitive) = 0 + or else Self.First not in 'a' .. 'z' + then + declare + Next_Try : Natural := Index (First_In_Data, Self.First); + begin + while Next_Try /= 0 loop + Matched := Try (Next_Try); + exit when Matched; + Next_Try := Index (Next_Try + 1, Self.First); + end loop; + end; + else + declare + Uc_First : constant Character := To_Upper (Self.First); + + function Case_Insensitive_Index + (Start : Positive) return Natural; + -- Search for both Self.First and To_Upper (Self.First). + -- If both are nonzero, return the smaller one; if exactly + -- one is nonzero, return it; if both are zero, return zero. + + --------------------------- + -- Case_Insenstive_Index -- + --------------------------- + + function Case_Insensitive_Index + (Start : Positive) return Natural + is + Lc_Index : constant Natural := Index (Start, Self.First); + Uc_Index : constant Natural := Index (Start, Uc_First); + begin + if Lc_Index = 0 then + return Uc_Index; + elsif Uc_Index = 0 then + return Lc_Index; + else + return Natural'Min (Lc_Index, Uc_Index); + end if; + end Case_Insensitive_Index; - begin - while Next_Try /= 0 loop - Matched := Try (Next_Try); - exit when Matched; - Next_Try := Index (Next_Try + 1, Self.First); - end loop; - end; + Next_Try : Natural := Case_Insensitive_Index (First_In_Data); + begin + while Next_Try /= 0 loop + Matched := Try (Next_Try); + exit when Matched; + Next_Try := Case_Insensitive_Index (Next_Try + 1); + end loop; + end; + end if; else -- Messy cases: try all locations (including for the empty string) @@ -3634,6 +3674,9 @@ package body System.Regpat is if Program (Scan) = EXACT then Self.First := Program (String_Operand (Scan)); + elsif Program (Scan) = EXACTF then + Self.First := To_Lower (Program (String_Operand (Scan))); + elsif Program (Scan) = BOL or else Program (Scan) = SBOL or else Program (Scan) = MBOL diff --git a/gcc/ada/libgnat/s-regpat.ads b/gcc/ada/libgnat/s-regpat.ads index b1a1366f..8fac30a 100644 --- a/gcc/ada/libgnat/s-regpat.ads +++ b/gcc/ada/libgnat/s-regpat.ads @@ -482,18 +482,17 @@ package System.Regpat is -- Data_First is the lower bound for the match, i.e. Data (Data_First) -- will be the first character to be examined. If Data_First is set to -- the special value of -1 (the default), then the first character to - -- be examined is Data (Data_First). However, the regular expression - -- character ^ (start of string) still refers to the first character + -- be examined is Data (Data'First). However, the regular expression + -- character ^ (start of string) always refers to the first character -- of the full string (Data (Data'First)), which is why there is a -- separate mechanism for specifying Data_First. -- Data_Last is the upper bound for the match, i.e. Data (Data_Last) -- will be the last character to be examined. If Data_Last is set to -- the special value of Positive'Last (the default), then the last - -- character to be examined is Data (Data_Last). However, the regular - -- expression character $ (end of string) still refers to the last - -- character of the full string (Data (Data'Last)), which is why there - -- is a separate mechanism for specifying Data_Last. + -- character to be examined is Data (Data'Last). However, the regular + -- expression character $ (end of string) always refers to the last + -- character of the full string (Data (Data'Last)). -- Note: the use of Data_First and Data_Last is not equivalent to -- simply passing a slice as Expression because of the handling of diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads index 7d6b1b9..6648c23 100644 --- a/gcc/ada/libgnat/s-secsta.ads +++ b/gcc/ada/libgnat/s-secsta.ads @@ -440,4 +440,9 @@ private function Get_Stack_Info (Stack : SS_Stack_Ptr) return Stack_Info; -- Obtain the information attributes of secondary stack Stack + pragma Machine_Attribute (SS_Allocate, "strub", "callable"); + pragma Machine_Attribute (SS_Mark, "strub", "callable"); + pragma Machine_Attribute (SS_Release, "strub", "callable"); + -- Enable these to be called from within strub contexts. + end System.Secondary_Stack; diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb index 5a74f8b..db0a5f2 100644 --- a/gcc/ada/live.adb +++ b/gcc/ada/live.adb @@ -45,7 +45,8 @@ package body Live is -- any valuable per-node space and possibly results in better locality and -- cache usage. - type Name_Set is array (Node_Id range <>) of Boolean; + type Name_Set is array (Node_Id'Base range <>) of Boolean; + -- We use 'Base here, in case we want to add a predicate to Node_Id pragma Pack (Name_Set); function Marked (Marks : Name_Set; Name : Node_Id) return Boolean; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 6e74e90..10276fa 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -1168,7 +1168,7 @@ package body Make is end if; else - ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); + ALI := Scan_ALI (Lib_File, Text, Err => True); Free (Text); if ALI = No_ALI_Id then @@ -2647,7 +2647,7 @@ package body Make is if Text /= null then ALI := Scan_ALI - (Data.Lib_File, Text, Ignore_ED => False, Err => True); + (Data.Lib_File, Text, Err => True); if ALI = No_ALI_Id then diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 3786d2c..3ccd630 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1031,22 +1031,6 @@ package Opt is -- GNATBIND -- Set to True to enable XDR in s-stratt.adb. Set by -xdr. - type Create_Repinfo_File_Proc is access procedure (Src : String); - type Write_Repinfo_Line_Proc is access procedure (Info : String); - type Close_Repinfo_File_Proc is access procedure; - -- Types used for procedure addresses below - - Create_Repinfo_File_Access : Create_Repinfo_File_Proc := null; - Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null; - Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null; - -- GNAT - -- These three locations are left null when operating in non-compiler (e.g. - -- ASIS mode), but when operating in compiler mode, they are set to point - -- to the three corresponding procedures in Osint-C. The reason for this - -- slightly strange interface is to stop Repinfo from dragging in Osint in - -- ASIS mode, which would include lots of unwanted units in the ASIS build. - -- ??? Revisit this now that ASIS mode is gone. - type Create_List_File_Proc is access procedure (S : String); type Write_List_Info_Proc is access procedure (S : String); type Close_List_File_Proc is access procedure; diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb index 14c6993..d08b082 100644 --- a/gcc/ada/osint-c.adb +++ b/gcc/ada/osint-c.adb @@ -520,10 +520,6 @@ package body Osint.C is begin Adjust_OS_Resource_Limits; - Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access; - Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access; - Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access; - Opt.Create_List_File_Access := Create_List_File'Access; Opt.Write_List_Info_Access := Write_List_Info'Access; Opt.Close_List_File_Access := Close_List_File'Access; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 4ee6aa8..cf39128 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -2373,14 +2373,12 @@ package body Osint is Nb_Relative_Dir := 0; for J in 1 .. Len loop - -- Treat any control character as a path separator. Note that we do + -- Treat any EOL character as a path separator. Note that we do -- not treat space as a path separator (we used to treat space as a -- path separator in an earlier version). That way space can appear -- as a legitimate character in a path name. - -- Why do we treat all control characters as path separators??? - - if S (J) in ASCII.NUL .. ASCII.US then + if S (J) = ASCII.LF or else S (J) = ASCII.CR then S (J) := Path_Separator; end if; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index e886b92..00202fd 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -467,6 +467,32 @@ package body Output is end if; end Write_Int; + ------------------ + -- Write_Int_64 -- + ------------------ + + procedure Write_Int_64 (Val : Int_64) is + subtype Nonpositive is Int_64 range Int_64'First .. 0; + procedure Write_Abs (Val : Nonpositive); + + procedure Write_Abs (Val : Nonpositive) is + begin + if Val < -9 then + Write_Abs (Val / 10); + end if; + + Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0'))); + end Write_Abs; + + begin + if Val < 0 then + Write_Char ('-'); + Write_Abs (Val); + else + Write_Abs (-Val); + end if; + end Write_Int_64; + ---------------- -- Write_Line -- ---------------- diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 6a36533..5058d6d 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -124,6 +124,7 @@ package Output is -- Similar as Write_Eol, except that trailing spaces are not removed procedure Write_Int (Val : Int); + procedure Write_Int_64 (Val : Int_64); -- Write an integer value with no leading blanks or zeroes. Negative values -- are preceded by a minus sign). diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 20f8dd1..b6cc1a0 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -3518,62 +3518,62 @@ package body Ch4 is Assoc_Node := New_Node (N_Iterated_Component_Association, Prev_Token_Ptr); - if Token = Tok_In then - Set_Defining_Identifier (Assoc_Node, Id); - T_In; - Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List); + case Token is + when Tok_In => + Set_Defining_Identifier (Assoc_Node, Id); + T_In; + Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List); - -- The iterator may include a filter + -- The iterator may include a filter - if Token = Tok_When then - Scan; -- past WHEN - Filter := P_Condition; - end if; + if Token = Tok_When then + Scan; -- past WHEN + Filter := P_Condition; + end if; - if Token = Tok_Use then + if Token = Tok_Use then - -- Ada 2022 Key-expression is present, rewrite node as an - -- Iterated_Element_Association. + -- Ada 2022 Key-expression is present, rewrite node as an + -- Iterated_Element_Association. - Scan; -- past USE - Build_Iterated_Element_Association; - Set_Key_Expression (Assoc_Node, P_Expression); + Scan; -- past USE + Build_Iterated_Element_Association; + Set_Key_Expression (Assoc_Node, P_Expression); - elsif Present (Filter) then - -- A loop_parameter_specification also indicates an Ada 2022 - -- construct, in contrast with a subtype indication used in - -- array aggregates. + elsif Present (Filter) then + -- A loop_parameter_specification also indicates an Ada 2022 + -- construct, in contrast with a subtype indication used in + -- array aggregates. - Build_Iterated_Element_Association; - end if; + Build_Iterated_Element_Association; + end if; - TF_Arrow; - Set_Expression (Assoc_Node, P_Expression); + TF_Arrow; + Set_Expression (Assoc_Node, P_Expression); - elsif Ada_Version >= Ada_2022 - and then Token = Tok_Of - then - Restore_Scan_State (State); - Scan; -- past OF - Set_Defining_Identifier (Assoc_Node, Id); - Iter_Spec := P_Iterator_Specification (Id); - Set_Iterator_Specification (Assoc_Node, Iter_Spec); - - if Token = Tok_Use then - Scan; -- past USE - -- This is an iterated_element_association - - Assoc_Node := - New_Node (N_Iterated_Element_Association, Prev_Token_Ptr); + when Tok_Of => + Restore_Scan_State (State); + Scan; -- past OF + Set_Defining_Identifier (Assoc_Node, Id); + Iter_Spec := P_Iterator_Specification (Id); Set_Iterator_Specification (Assoc_Node, Iter_Spec); - Set_Key_Expression (Assoc_Node, P_Expression); - end if; - TF_Arrow; - Set_Expression (Assoc_Node, P_Expression); - end if; + if Token = Tok_Use then + Scan; -- past USE + -- This is an iterated_element_association - Error_Msg_Ada_2022_Feature ("iterated component", Token_Ptr); + Assoc_Node := + New_Node (N_Iterated_Element_Association, Prev_Token_Ptr); + Set_Iterator_Specification (Assoc_Node, Iter_Spec); + Set_Key_Expression (Assoc_Node, P_Expression); + end if; + + TF_Arrow; + Set_Expression (Assoc_Node, P_Expression); + + when others => + Error_Msg_AP ("missing IN or OF"); + end case; return Assoc_Node; end P_Iterated_Component_Association; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 06c7d87..e1258e0 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1338,6 +1338,7 @@ begin | Pragma_CPP_Virtual | Pragma_CPP_Vtable | Pragma_CPU + | Pragma_CUDA_Device | Pragma_CUDA_Execute | Pragma_CUDA_Global | Pragma_C_Pass_By_Copy diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 513275a..09e4d50 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -216,9 +216,6 @@ package body Par_SCO is -- Parameter D, when present, indicates the dominant of the first -- declaration or statement within N. - -- Why is Traverse_Sync_Definition commented specifically, whereas - -- the others are not??? - procedure Traverse_Generic_Package_Declaration (N : Node_Id); procedure Traverse_Handled_Statement_Sequence @@ -235,8 +232,7 @@ package body Par_SCO is (N : Node_Id; D : Dominant_Info := No_Dominant); - procedure Traverse_Sync_Definition (N : Node_Id); - -- Traverse a protected definition or task definition + procedure Traverse_Protected_Or_Task_Definition (N : Node_Id); -- Note regarding traversals: In a few cases where an Alternatives list is -- involved, pragmas such as "pragma Page" may show up before the first @@ -690,9 +686,6 @@ package body Par_SCO is -- fully equivalent to the "To" sloc computed by -- Sloc_Range (Guard, To, From). - -- Doesn't this requirement of using First_Sloc need to be - -- documented in the spec ??? - if Nkind (Parent (N)) in N_Accept_Alternative | N_Delay_Alternative | N_Terminate_Alternative @@ -834,6 +827,14 @@ package body Par_SCO is return Skip; end; + when N_Quantified_Expression => + declare + Cond : constant Node_Id := Condition (N); + begin + Process_Decisions (Cond, 'W', Pragma_Sloc); + return Skip; + end; + -- All other cases, continue scan when others => @@ -2331,7 +2332,7 @@ package body Par_SCO is Process_Decisions_Defer (Discriminant_Specifications (N), 'X'); Set_Statement_Entry; - Traverse_Sync_Definition (N); + Traverse_Protected_Or_Task_Definition (N); when N_Single_Protected_Declaration | N_Single_Task_Declaration @@ -2339,7 +2340,7 @@ package body Par_SCO is Extend_Statement_Sequence (N, 'o'); Set_Statement_Entry; - Traverse_Sync_Definition (N); + Traverse_Protected_Or_Task_Definition (N); when others => @@ -2517,11 +2518,11 @@ package body Par_SCO is Traverse_Declarations_Or_Statements (Private_Declarations (Spec), Dom); end Traverse_Package_Declaration; - ------------------------------ - -- Traverse_Sync_Definition -- - ------------------------------ + ------------------------------------------- + -- Traverse_Protected_Or_Task_Definition -- + ------------------------------------------- - procedure Traverse_Sync_Definition (N : Node_Id) is + procedure Traverse_Protected_Or_Task_Definition (N : Node_Id) is Dom_Info : Dominant_Info := ('S', N); -- The first declaration is dominated by the protected or task [type] -- declaration. @@ -2570,7 +2571,7 @@ package body Par_SCO is Traverse_Declarations_Or_Statements (L => Priv_Decl, D => Dom_Info); - end Traverse_Sync_Definition; + end Traverse_Protected_Or_Task_Definition; -------------------------------------- -- Traverse_Subprogram_Or_Task_Body -- diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb index f7717bf..b76bd91 100644 --- a/gcc/ada/pprint.adb +++ b/gcc/ada/pprint.adb @@ -100,7 +100,7 @@ package body Pprint is Add_Space : Boolean := True; Add_Paren : Boolean := True; Num : Natural := 1) return String; - -- ??? what does this do + -- Created for purposes of recursing on embedded lists ------------------------ -- Internal_List_Name -- @@ -113,30 +113,6 @@ package body Pprint is Add_Paren : Boolean := True; Num : Natural := 1) return String is - function Prepend (S : String) return String; - -- ??? what does this do - - ------------- - -- Prepend -- - ------------- - - function Prepend (S : String) return String is - begin - if Add_Space then - if Add_Paren then - return " (" & S; - else - return ' ' & S; - end if; - elsif Add_Paren then - return '(' & S; - else - return S; - end if; - end Prepend; - - -- Start of processing for Internal_List_Name - begin if not Present (List) then if First or else not Add_Paren then @@ -152,23 +128,22 @@ package body Pprint is end if; end if; - -- ??? the Internal_List_Name calls can be factored out - - if First then - return Prepend (Expr_Name (List) - & Internal_List_Name - (List => Next (List), - First => False, - Add_Paren => Add_Paren, - Num => Num + 1)); - else - return ", " & Expr_Name (List) - & Internal_List_Name - (List => Next (List), - First => False, - Add_Paren => Add_Paren, - Num => Num + 1); - end if; + -- Continue recursing on the list - handling the first element + -- in a special way. + + return + (if First then + (if Add_Space and Add_Paren then " (" + elsif Add_Paren then "(" + elsif Add_Space then " " + else "") + else ", ") + & Expr_Name (List) + & Internal_List_Name + (List => Next (List), + First => False, + Add_Paren => Add_Paren, + Num => Num + 1); end Internal_List_Name; -- Start of processing for List_Name diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index 37556d5..e01161c 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -1410,7 +1410,12 @@ package body Prep is Scan.all; - if Token /= Tok_If then + -- Ignore all recoverable errors if Relaxed_RM_Semantics + + if Relaxed_RM_Semantics then + null; + + elsif Token /= Tok_If then Error_Msg -- CODEFIX ("IF expected", Token_Ptr); No_Error_Found := False; @@ -1453,21 +1458,31 @@ package body Prep is -- Illegal preprocessor line when others => - No_Error_Found := False; - if Pp_States.Last = 0 then Error_Msg -- CODEFIX ("IF expected", Token_Ptr); + No_Error_Found := False; - elsif - Pp_States.Table (Pp_States.Last).Else_Ptr = 0 + elsif Relaxed_RM_Semantics + and then Get_Name_String (Token_Name) = "endif" then + -- In relaxed mode, accept "endif" instead of + -- "end if". + + -- Decrement the depth of the #if stack + + if Pp_States.Last > 0 then + Pp_States.Decrement_Last; + end if; + elsif Pp_States.Table (Pp_States.Last).Else_Ptr = 0 then Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected", Token_Ptr); + No_Error_Found := False; else Error_Msg ("IF or `END IF` expected", Token_Ptr); + No_Error_Found := False; end if; -- Skip to the end of this illegal line diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 58e0161..084ca91 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -35,6 +35,7 @@ with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; with Output; use Output; +with Osint.C; use Osint.C; with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sinfo; use Sinfo; @@ -1724,7 +1725,7 @@ package body Repinfo is -- List representation information to file else - Create_Repinfo_File_Access.all + Create_Repinfo_File (Get_Name_String (File_Name (Source_Index (U)))); Set_Special_Output (Write_Info_Line'Access); if List_Representation_Info_To_JSON then @@ -1736,7 +1737,7 @@ package body Repinfo is Write_Line ("]"); end if; Cancel_Special_Output; - Close_Repinfo_File_Access.all; + Close_Repinfo_File; end if; end if; end loop; @@ -2328,7 +2329,7 @@ package body Repinfo is procedure Write_Info_Line (S : String) is begin - Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1)); + Write_Repinfo_Line (S (S'First .. S'Last - 1)); end Write_Info_Line; --------------------- diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index bf1307c..fb42e30b 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1743,13 +1743,13 @@ package body Scng is Code := Character'Pos (' '); -- In Ada 95 mode we allow any wide character in a character - -- literal, but in Ada 2005, the set of characters allowed - -- is restricted to graphic characters. + -- literal, but in later versions, the set of characters + -- allowed is restricted to graphic characters. elsif Ada_Version >= Ada_2005 and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) then - Error_Msg -- CODEFIX???? + Error_Msg -- CODEFIX ("(Ada 2005) non-graphic character not permitted " & "in character literal", Wptr); end if; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index d8e88dd..cdac552 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -257,7 +257,7 @@ package SCOs is -- I decision in IF statement or if expression -- P decision in pragma Assert / Check / Pre/Post_Condition -- A[name] decision in aspect Pre/Post (aspect name optional) - -- W decision in WHILE iteration scheme + -- W decision in WHILE iteration scheme or quantified expression -- X decision in some other expression context -- For E, G, I, P, W, sloc is the source location of the EXIT, ENTRY, IF, diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 783c94aa..3eee2ee 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1402,7 +1402,9 @@ package body Sem is procedure Do_Analyze is 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 + Saved_ISMP : constant Boolean := + Ignore_SPARK_Mode_Pragmas_In_Instance; + -- Save Ghost and SPARK mode-related data to restore on exit -- Generally style checks are preserved across compilations, with -- one exception: s-oscons.ads, which allows arbitrary long lines @@ -1421,6 +1423,7 @@ package body Sem is -- Set up a clean environment before analyzing Install_Ghost_Region (None, Empty); + Ignore_SPARK_Mode_Pragmas_In_Instance := False; Outer_Generic_Scope := Empty; Scope_Suppress := Suppress_Options; @@ -1443,9 +1446,11 @@ package body Sem is Pop_Scope; Restore_Scope_Stack (List); - Restore_Ghost_Region (Saved_GM, Saved_IGR); Style_Max_Line_Length := Saved_ML; Style_Check_Max_Line_Length := Saved_CML; + + Restore_Ghost_Region (Saved_GM, Saved_IGR); + Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; end Do_Analyze; -- Local variables diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 2fdccf7..699f685 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -291,6 +291,10 @@ package Sem is -- freezing nodes can modify the status of this flag, any other client -- should regard it as read-only. + Inside_Class_Condition_Preanalysis : Boolean := False; + -- Flag indicating whether we are preanalyzing a class-wide precondition + -- or postcondition. + Inside_Preanalysis_Without_Freezing : Nat := 0; -- Flag indicating whether we are preanalyzing an expression performing no -- freezing. Non-zero means we are inside (it is actually a level counter diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9ad9629..9ae5ff6 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -365,7 +365,7 @@ package body Sem_Aggr is -- to the expansion phase. As an optimization, if the discrete choice -- specifies a single value we do not delay resolution. - function Array_Aggr_Subtype (N : Node_Id; Typ : Node_Id) return Entity_Id; + function Array_Aggr_Subtype (N : Node_Id; Typ : Entity_Id) return Entity_Id; -- This routine returns the type or subtype of an array aggregate. -- -- N is the array aggregate node whose type we return. @@ -545,6 +545,14 @@ package body Sem_Aggr is -- Make sure that the list of index constraints is properly attached to -- the tree, and then collect the aggregate bounds. + -- If no aggregaate bounds have been set, this is an aggregate with + -- iterator specifications and a dynamic size to be determined by + -- first pass of expanded code. + + if No (Aggregate_Bounds (N)) then + return Typ; + end if; + Set_Parent (Index_Constraints, N); Collect_Aggr_Bounds (N, 1); @@ -1597,6 +1605,8 @@ package body Sem_Aggr is Loc : constant Source_Ptr := Sloc (N); Id : constant Entity_Id := Defining_Identifier (N); + Id_Typ : Entity_Id := Any_Type; + ----------------------- -- Remove_References -- ----------------------- @@ -1630,42 +1640,65 @@ package body Sem_Aggr is -- Start of processing for Resolve_Iterated_Component_Association begin - -- An element iterator specification cannot appear in - -- an array aggregate because it does not provide index - -- values for the association. This must be a semantic - -- check because the parser cannot tell whether this is - -- an array aggregate or a container aggregate. + Error_Msg_Ada_2022_Feature ("iterated component", Loc); if Present (Iterator_Specification (N)) then - Error_Msg_N ("container element Iterator cannot appear " - & "in an array aggregate", N); - return; - end if; + Analyze (Name (Iterator_Specification (N))); - Choice := First (Discrete_Choices (N)); + -- We assume that the domain of iteration cannot be overloaded. - while Present (Choice) loop - if Nkind (Choice) = N_Others_Choice then - Others_Present := True; + declare + Domain : constant Node_Id := Name (Iterator_Specification (N)); + D_Type : constant Entity_Id := Etype (Domain); + Elt : Entity_Id; + begin + if Is_Array_Type (D_Type) then + Id_Typ := Component_Type (D_Type); - else - Analyze (Choice); + else + if Has_Aspect (D_Type, Aspect_Iterable) then + Elt := + Get_Iterable_Type_Primitive (D_Type, Name_Element); + if No (Elt) then + Error_Msg_N + ("missing Element primitive for iteration", Domain); + else + Id_Typ := Etype (Elt); + end if; + else + Error_Msg_N ("cannot iterate over", Domain); + end if; + end if; + end; - -- Choice can be a subtype name, a range, or an expression + else + Id_Typ := Index_Typ; + Choice := First (Discrete_Choices (N)); - if Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - and then Base_Type (Entity (Choice)) = Base_Type (Index_Typ) - then - null; + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Others_Present := True; else - Analyze_And_Resolve (Choice, Index_Typ); + Analyze (Choice); + + -- Choice can be a subtype name, a range, or an expression + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + and then + Base_Type (Entity (Choice)) = Base_Type (Index_Typ) + then + null; + + else + Analyze_And_Resolve (Choice, Index_Typ); + end if; end if; - end if; - Next (Choice); - end loop; + Next (Choice); + end loop; + 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 @@ -1681,7 +1714,7 @@ package body Sem_Aggr is -- directly visible. Enter_Name (Id); - Set_Etype (Id, Index_Typ); + Set_Etype (Id, Id_Typ); Mutate_Ekind (Id, E_Variable); Set_Scope (Id, Ent); @@ -1735,6 +1768,12 @@ package body Sem_Aggr is Delete_Choice : Boolean; -- Used when replacing a subtype choice with predicate by a list + Has_Iterator_Specifications : Boolean := False; + -- Flag to indicate that all named associations are iterated component + -- associations with iterator specifications, in which case the + -- expansion will create two loops: one to evaluate the size and one + -- to generate the elements (4.3.3 (20.2/5)). + Nb_Elements : Uint := Uint_0; -- The number of elements in a positional aggregate @@ -1756,6 +1795,54 @@ package body Sem_Aggr is -- STEP 1: make sure the aggregate is correctly formatted if Present (Component_Associations (N)) then + + -- Verify that all or none of the component associations + -- include an iterator specification. + + Assoc := First (Component_Associations (N)); + if Nkind (Assoc) = N_Iterated_Component_Association + and then Present (Iterator_Specification (Assoc)) + then + -- All other component associations must have an iterator spec. + + Next (Assoc); + while Present (Assoc) loop + if Nkind (Assoc) /= N_Iterated_Component_Association + or else No (Iterator_Specification (Assoc)) + then + Error_Msg_N ("mixed iterated component association" + & " (RM 4.4.3 (17.1/5))", + Assoc); + return False; + end if; + + Next (Assoc); + end loop; + + Has_Iterator_Specifications := True; + + else + -- or none of them do. + + Next (Assoc); + while Present (Assoc) loop + if Nkind (Assoc) = N_Iterated_Component_Association + and then Present (Iterator_Specification (Assoc)) + then + Error_Msg_N ("mixed iterated component association" + & " (RM 4.4.3 (17.1/5))", + Assoc); + return False; + end if; + + Next (Assoc); + end loop; + + while Present (Assoc) loop + Next (Assoc); + end loop; + end if; + Assoc := First (Component_Associations (N)); while Present (Assoc) loop if Nkind (Assoc) = N_Iterated_Component_Association then @@ -1867,7 +1954,7 @@ package body Sem_Aggr is or else (Nb_Choices = 1 and then not Others_Present)) then Error_Msg_N - ("named association cannot follow positional association", + ("cannot mix named and positional associations in array aggregate", First (Choice_List (First (Component_Associations (N))))); return Failure; end if; @@ -1948,9 +2035,12 @@ package body Sem_Aggr is begin -- STEP 2 (A): Check discrete choices validity + -- No need if this is an element iteration. Assoc := First (Component_Associations (N)); - while Present (Assoc) loop + while Present (Assoc) + and then Present (Choice_List (Assoc)) + loop Prev_Nb_Discrete_Choices := Nb_Discrete_Choices; Choice := First (Choice_List (Assoc)); @@ -2391,6 +2481,12 @@ package body Sem_Aggr is end Check_Choices; end if; + if Has_Iterator_Specifications then + -- Bounds will be determined dynamically. + + return Success; + end if; + -- STEP 2 (B): Compute aggregate bounds and min/max choices values if Nb_Discrete_Choices > 0 then @@ -2706,7 +2802,10 @@ package body Sem_Aggr is -- Exp_Aggr.Convert_To_Positional, so we don't want to change those -- bounds. - if Present (Aggregate_Bounds (N)) and then not Others_Allowed then + if Present (Aggregate_Bounds (N)) + and then not Others_Allowed + and then not Comes_From_Source (N) + then Aggr_Low := Low_Bound (Aggregate_Bounds (N)); Aggr_High := High_Bound (Aggregate_Bounds (N)); end if; @@ -2770,6 +2869,7 @@ package body Sem_Aggr is Key_Type : Entity_Id; Elmt_Type : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); Choice : Node_Id; Ent : Entity_Id; Expr : Node_Id; @@ -2780,6 +2880,8 @@ package body Sem_Aggr is Typ : Entity_Id := Empty; begin + Error_Msg_Ada_2022_Feature ("iterated component", Loc); + -- 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. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index b44bbe3..4d69d58 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1339,6 +1339,16 @@ package body Sem_Attr is Legal := False; Spec_Id := Empty; + -- Skip processing during preanalysis of class-wide preconditions and + -- postconditions since at this stage the expression is not installed + -- yet on its definite context. + + if Inside_Class_Condition_Preanalysis then + Legal := True; + Spec_Id := Current_Scope; + return; + end if; + -- Traverse the parent chain to find the aspect or pragma where the -- attribute resides. @@ -1519,14 +1529,6 @@ package body Sem_Attr is Check_E1; Set_Etype (N, Str_Typ); - -- ???It's not clear why 'Img should behave any differently than - -- 'Image. - - if Attr_Id = Attribute_Img then - Error_Attr_P - ("prefix of % attribute must be a scalar object name"); - end if; - pragma Assert (Is_Entity_Name (P) and then Is_Type (Entity (P))); if Ekind (Entity (P)) = E_Incomplete_Type @@ -6641,7 +6643,9 @@ package body Sem_Attr is Initialize (CRC); Compute_Type_Key (Entity (P)); - if not Is_Frozen (Entity (P)) then + if not Is_Frozen (Entity (P)) + and then not Is_Generic_Type (Entity (P)) + then Error_Msg_N ("premature usage of Type_Key?", N); end if; @@ -9131,12 +9135,26 @@ package body Sem_Attr is -- Leading_Part -- ------------------ - when Attribute_Leading_Part => + when Attribute_Leading_Part => Leading_Part : declare + Radix_Digits : constant Uint := Expr_Value (E2); + + begin + if UI_Le (Radix_Digits, Uint_0) then + Apply_Compile_Time_Constraint_Error + (N, "Radix_Digits in Leading_Part is zero or negative", + CE_Explicit_Raise, + Warn => not Static); + + Check_Expressions; + return; + end if; + Fold_Ureal (N, Eval_Fat.Leading_Part - (P_Base_Type, Expr_Value_R (E1), Expr_Value (E2)), + (P_Base_Type, Expr_Value_R (E1), Radix_Digits), Static); + end Leading_Part; ------------ -- Length -- @@ -11488,28 +11506,45 @@ package body Sem_Attr is -- in such a context - unless the restriction -- No_Dynamic_Accessibility_Checks is active. - if Attr_Id /= Attribute_Unchecked_Access - and then - (Ekind (Btyp) = E_General_Access_Type - or else No_Dynamic_Accessibility_Checks_Enabled (Btyp)) - - -- 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 ??? + declare + No_Dynamic_Acc_Checks : constant Boolean := + No_Dynamic_Accessibility_Checks_Enabled (Btyp); - and then Nkind (Accessibility_Level (P, Dynamic_Level)) - = N_Integer_Literal - and then - Intval (Accessibility_Level (P, Dynamic_Level)) - > Deepest_Type_Access_Level (Btyp) - then - Accessibility_Message; - return; - end if; + Compatible_Alt_Checks : constant Boolean := + No_Dynamic_Acc_Checks and then not Debug_Flag_Underscore_B; + begin + if Attr_Id /= Attribute_Unchecked_Access + and then (Ekind (Btyp) = E_General_Access_Type + or else No_Dynamic_Acc_Checks) + + -- In the case of the alternate "compatibility" + -- accessibility model we do not perform a static + -- accessibility check on actuals for anonymous access + -- types - so exclude them here. + + and then not (Compatible_Alt_Checks + and then Is_Actual_Parameter (N) + and then Ekind (Btyp) + = E_Anonymous_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 + Intval (Accessibility_Level (P, Dynamic_Level)) + > Deepest_Type_Access_Level (Btyp) + then + Accessibility_Message; + return; + end if; + end; end if; if Ekind (Btyp) in E_Access_Protected_Subprogram_Type @@ -12477,7 +12512,7 @@ package body Sem_Attr is function Stream_Attribute_Available (Typ : Entity_Id; Nam : TSS_Name_Type; - Partial_View : Node_Id := Empty) return Boolean + Partial_View : Entity_Id := Empty) return Boolean is Etyp : Entity_Id := Typ; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index bce7c38..dcced7e 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1402,6 +1402,31 @@ package body Sem_Aux is end Object_Type_Has_Constrained_Partial_View; ------------------ + -- Package_Body -- + ------------------ + + function Package_Body (E : Entity_Id) return Node_Id is + Body_Decl : Node_Id; + Body_Id : constant Opt_E_Package_Body_Id := + Corresponding_Body (Package_Spec (E)); + + begin + if Present (Body_Id) then + Body_Decl := Parent (Body_Id); + + if Nkind (Body_Decl) = N_Defining_Program_Unit_Name then + Body_Decl := Parent (Body_Decl); + end if; + + pragma Assert (Nkind (Body_Decl) = N_Package_Body); + + return Body_Decl; + else + return Empty; + end if; + end Package_Body; + + ------------------ -- Package_Spec -- ------------------ diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 810e2d8..3adaee4 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -377,6 +377,10 @@ package Sem_Aux is -- derived type, and the subtype is not an unconstrained array subtype -- (RM 3.3(23.10/3)). + function Package_Body (E : Entity_Id) return Node_Id; + -- Given an entity for a package, return the corresponding package body, if + -- any, or else Empty. + function Package_Spec (E : Entity_Id) return Node_Id; -- Given an entity for a package spec, return the corresponding package -- spec if any, or else Empty. diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 7d08da5..31f14d5 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -44,6 +44,7 @@ with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; +with Stringt; use Stringt; with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -105,25 +106,70 @@ package body Sem_Case is package Composite_Case_Ops is + function Choice_Count (Alternatives : List_Id) return Nat; + -- The sum of the number of choices for each alternative in the given + -- list. + function Scalar_Part_Count (Subtyp : Entity_Id) return Nat; -- Given the composite type Subtyp of a case selector, returns the -- number of scalar parts in an object of this type. This is the -- dimensionality of the associated Cartesian product space. - function Choice_Count (Alternatives : List_Id) return Nat; - -- The sum of the number of choices for each alternative in the given - -- list. + package Array_Case_Ops is + function Array_Choice_Length (Choice : Node_Id) return Nat; + -- Given a choice expression of an array type, returns its length. + + function Normalized_Case_Expr_Type + (Case_Statement : Node_Id) return Entity_Id; + -- Usually returns the Etype of the selector expression of the + -- case statement. However, in the case of a constrained array + -- subtype with a nonstatic constraint, returns the unconstrained + -- array base type. + + function Unconstrained_Array_Effective_Length + (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat; + -- If the nominal subtype of the case selector is unconstrained, + -- then use the length of the longest choice of the case statement. + -- Components beyond that index value will not influence the case + -- selection decision. + + function Unconstrained_Array_Scalar_Part_Count + (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat; + -- Same as Scalar_Part_Count except that the value used for the + -- "length" of the array subtype being cased on is determined by + -- calling Unconstrained_Array_Effective_Length. + end Array_Case_Ops; generic Case_Statement : Node_Id; package Choice_Analysis is + use Array_Case_Ops; + type Alternative_Id is new Int range 1 .. List_Length (Alternatives (Case_Statement)); type Choice_Id is new Int range 1 .. Choice_Count (Alternatives (Case_Statement)); + + Case_Expr_Type : constant Entity_Id := + Normalized_Case_Expr_Type (Case_Statement); + + Unconstrained_Array_Case : constant Boolean := + Is_Array_Type (Case_Expr_Type) + and then not Is_Constrained (Case_Expr_Type); + + -- If Unconstrained_Array_Case is True, choice lengths may differ: + -- when "Aaa" | "Bb" | "C" | "" => + -- + -- Strictly speaking, the name "Unconstrained_Array_Case" is + -- slightly imprecise; a subtype with a nonstatic constraint is + -- also treated as unconstrained (see Normalize_Case_Expr_Type). + type Part_Id is new Int range - 1 .. Scalar_Part_Count (Etype (Expression (Case_Statement))); + 1 .. (if Unconstrained_Array_Case + then Unconstrained_Array_Scalar_Part_Count + (Case_Expr_Type, Case_Statement) + else Scalar_Part_Count (Case_Expr_Type)); type Discrete_Range_Info is record @@ -1118,6 +1164,21 @@ package body Sem_Case is return UI_To_Int (Len); end Static_Array_Length; + ------------------ + -- Choice_Count -- + ------------------ + + function Choice_Count (Alternatives : List_Id) return Nat is + Result : Nat := 0; + Alt : Node_Id := First (Alternatives); + begin + while Present (Alt) loop + Result := Result + List_Length (Discrete_Choices (Alt)); + Next (Alt); + end loop; + return Result; + end Choice_Count; + ----------------------- -- Scalar_Part_Count -- ----------------------- @@ -1147,20 +1208,118 @@ package body Sem_Case is end if; end Scalar_Part_Count; - ------------------ - -- Choice_Count -- - ------------------ + package body Array_Case_Ops is - function Choice_Count (Alternatives : List_Id) return Nat is - Result : Nat := 0; - Alt : Node_Id := First (Alternatives); - begin - while Present (Alt) loop - Result := Result + List_Length (Discrete_Choices (Alt)); - Next (Alt); - end loop; - return Result; - end Choice_Count; + ------------------------- + -- Array_Choice_Length -- + ------------------------- + + function Array_Choice_Length (Choice : Node_Id) return Nat is + begin + case Nkind (Choice) is + when N_String_Literal => + return String_Length (Strval (Choice)); + when N_Aggregate => + declare + Bounds : constant Node_Id := + Aggregate_Bounds (Choice); + pragma Assert (Is_OK_Static_Range (Bounds)); + Lo : constant Uint := + Expr_Value (Low_Bound (Bounds)); + Hi : constant Uint := + Expr_Value (High_Bound (Bounds)); + Len : constant Uint := (Hi - Lo) + 1; + begin + return UI_To_Int (Len); + end; + when N_Has_Entity => + if Present (Entity (Choice)) + and then Ekind (Entity (Choice)) = E_Constant + then + return Array_Choice_Length + (Expression (Parent (Entity (Choice)))); + end if; + when N_Others_Choice => + return 0; + when others => + null; + end case; + + if Nkind (Original_Node (Choice)) + in N_String_Literal | N_Aggregate + then + return Array_Choice_Length (Original_Node (Choice)); + end if; + + Error_Msg_N ("Unsupported case choice", Choice); + return 0; + end Array_Choice_Length; + + ------------------------------- + -- Normalized_Case_Expr_Type -- + ------------------------------- + + function Normalized_Case_Expr_Type + (Case_Statement : Node_Id) return Entity_Id + is + Unnormalized : constant Entity_Id := + Etype (Expression (Case_Statement)); + begin + if Is_Array_Type (Unnormalized) + and then Is_Constrained (Unnormalized) + and then not Has_Static_Array_Bounds (Unnormalized) + then + return Base_Type (Unnormalized); + else + return Unnormalized; + end if; + end Normalized_Case_Expr_Type; + + ------------------------------------------ + -- Unconstrained_Array_Effective_Length -- + ------------------------------------------ + + function Unconstrained_Array_Effective_Length + (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat + is + pragma Assert (Is_Array_Type (Array_Type)); + -- Array_Type is otherwise unreferenced for now. + + Result : Nat := 0; + Alt : Node_Id := First (Alternatives (Case_Statement)); + begin + while Present (Alt) loop + declare + Choice : Node_Id := First (Discrete_Choices (Alt)); + begin + while Present (Choice) loop + Result := Nat'Max (Result, Array_Choice_Length (Choice)); + Next (Choice); + end loop; + end; + Next (Alt); + end loop; + + return Result; + end Unconstrained_Array_Effective_Length; + + ------------------------------------------- + -- Unconstrained_Array_Scalar_Part_Count -- + ------------------------------------------- + + function Unconstrained_Array_Scalar_Part_Count + (Array_Type : Entity_Id; Case_Statement : Node_Id) return Nat + is + begin + -- Add one for the length, which is treated like a discriminant + + return 1 + (Unconstrained_Array_Effective_Length + (Array_Type => Array_Type, + Case_Statement => Case_Statement) + * Scalar_Part_Count (Component_Type (Array_Type))); + end Unconstrained_Array_Scalar_Part_Count; + + end Array_Case_Ops; package body Choice_Analysis is @@ -1220,9 +1379,32 @@ package body Sem_Case is ((Low => Expr_Value (Type_Low_Bound (Subtyp)), High => Expr_Value (Type_High_Bound (Subtyp)))); elsif Is_Array_Type (Subtyp) then - for I in 1 .. Static_Array_Length (Subtyp) loop - Traverse_Discrete_Parts (Component_Type (Subtyp)); - end loop; + declare + Len : Nat; + begin + if Is_Constrained (Subtyp) then + Len := Static_Array_Length (Subtyp); + else + -- Length will be treated like a discriminant; + -- We could compute High more precisely as + -- 1 + Index_Subtype'Last - Index_Subtype'First + -- (we currently require that those bounds be + -- static, so this is an option), but only downside of + -- overshooting is if somebody wants to omit a + -- "when others" choice and exhaustively cover all + -- possibilities explicitly. + Update_Result + ((Low => Uint_0, + High => Uint_2 ** Uint_32)); + + Len := Unconstrained_Array_Effective_Length + (Array_Type => Subtyp, + Case_Statement => Case_Statement); + end if; + for I in 1 .. Len loop + Traverse_Discrete_Parts (Component_Type (Subtyp)); + end loop; + end; elsif Is_Record_Type (Subtyp) then if Has_Static_Discriminant_Constraint (Subtyp) then @@ -1274,7 +1456,7 @@ package body Sem_Case is end Traverse_Discrete_Parts; begin - Traverse_Discrete_Parts (Etype (Expression (Case_Statement))); + Traverse_Discrete_Parts (Case_Expr_Type); pragma Assert (Done or else Serious_Errors_Detected > 0); return Result; end Component_Bounds_Info; @@ -1531,6 +1713,19 @@ package body Sem_Case is & "choice not implemented", Expr); end if; + if not Unconstrained_Array_Case + and then List_Length (Expressions (Expr)) + /= Nat (Part_Id'Last) + then + Error_Msg_Uint_1 := UI_From_Int + (List_Length (Expressions (Expr))); + Error_Msg_Uint_2 := UI_From_Int (Int (Part_Id'Last)); + Error_Msg_N + ("array aggregate length ^ does not match length " & + "of statically constrained case selector ^", Expr); + return; + end if; + declare Subexpr : Node_Id := First (Expressions (Expr)); begin @@ -1542,9 +1737,51 @@ package body Sem_Case is else raise Program_Error; end if; + elsif Nkind (Expr) = N_String_Literal then + if not Is_Array_Type (Etype (Expr)) then + Error_Msg_N + ("User-defined string literal not allowed as/within" + & "case choice", Expr); + else + declare + Char_Type : constant Entity_Id := + Root_Type (Component_Type (Etype (Expr))); + + -- If the component type is not a standard character + -- type then this string lit should have already been + -- transformed into an aggregate in + -- Resolve_String_Literal. + -- + pragma Assert (Is_Standard_Character_Type (Char_Type)); + + Str : constant String_Id := Strval (Expr); + Strlen : constant Nat := String_Length (Str); + Char_Val : Uint; + begin + if not Unconstrained_Array_Case + and then Strlen /= Nat (Part_Id'Last) + then + Error_Msg_Uint_1 := UI_From_Int (Strlen); + Error_Msg_Uint_2 := UI_From_Int + (Int (Part_Id'Last)); + Error_Msg_N + ("String literal length ^ does not match length" & + " of statically constrained case selector ^", + Expr); + return; + end if; + + for Idx in 1 .. Strlen loop + Char_Val := + UI_From_CC (Get_String_Char (Str, Idx)); + Update_Result ((Low | High => Char_Val)); + end loop; + end; + end if; elsif Is_Discrete_Type (Etype (Expr)) then - if Nkind (Expr) in N_Has_Entity and then - Is_Type (Entity (Expr)) + if Nkind (Expr) in N_Has_Entity + and then Present (Entity (Expr)) + and then Is_Type (Entity (Expr)) then declare Low : constant Node_Id := @@ -1559,10 +1796,20 @@ package body Sem_Case is pragma Assert (Compile_Time_Known_Value (Expr)); Update_Result ((Low | High => Expr_Value (Expr))); end if; + elsif Nkind (Expr) in N_Has_Entity + and then Present (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Constant + then + Traverse_Choice (Expression (Parent (Entity (Expr)))); + elsif Nkind (Original_Node (Expr)) + in N_Aggregate | N_String_Literal + then + Traverse_Choice (Original_Node (Expr)); else Error_Msg_N - ("non-aggregate case choice subexpression which is not" - & " of a discrete type not implemented", Expr); + ("non-aggregate case choice (or subexpression thereof)" + & " that is not of a discrete type not implemented", + Expr); end if; end Traverse_Choice; @@ -1572,8 +1819,26 @@ package body Sem_Case is if Nkind (Choice) = N_Others_Choice then return (Is_Others => True); end if; + + if Unconstrained_Array_Case then + -- Treat length like a discriminant + Update_Result ((Low | High => + UI_From_Int (Array_Choice_Length (Choice)))); + end if; + Traverse_Choice (Choice); + if Unconstrained_Array_Case then + -- This is somewhat tricky. Suppose we are casing on String, + -- the longest choice in the case statement is length 10, and + -- the choice we are looking at now is of length 6. We fill + -- in the trailing 4 slots here. + while Next_Part <= Part_Id'Last loop + Update_Result_For_Full_Coverage + (Comp_Type => Component_Type (Case_Expr_Type)); + end loop; + end if; + -- Avoid returning uninitialized garbage in error case if Next_Part /= Part_Id'Last + 1 then pragma Assert (Serious_Errors_Detected > 0); @@ -2098,6 +2363,12 @@ package body Sem_Case is Result := Result * Value_Index_Base (Uint_Sets.Size (Set)); end loop; return Result; + exception + when Constraint_Error => + Error_Msg_N + ("Capacity exceeded in compiling case statement with" + & " composite selector type", Case_Statement); + raise; end Value_Index_Count; Max_Value_Index : constant Value_Index_Base := Value_Index_Count; @@ -3014,12 +3285,20 @@ package body Sem_Case is "an enumeration representation clause", N); end if; elsif Is_Array_Type (Subtyp) then - pragma Assert (Is_Constrained (Subtyp)); - if Number_Dimensions (Subtyp) /= 1 then Error_Msg_N ("dimensionality of array type of case selector (or " & "subcomponent thereof) is greater than 1", N); + + elsif not Is_Constrained (Subtyp) then + if not Is_Static_Subtype + (Etype (First_Index (Subtyp))) + then + Error_Msg_N + ("Unconstrained array subtype of case selector" & + " has nonstatic index subtype", N); + end if; + elsif not Is_OK_Static_Range (First_Index (Subtyp)) then Error_Msg_N ("array subtype of case selector (or " & @@ -3077,10 +3356,6 @@ package body Sem_Case is elsif Needs_Finalization (Subtyp) then Error_Msg_N ("case selector type requires finalization", N); - elsif Is_Array_Type (Subtyp) and not Is_Constrained (Subtyp) then - Error_Msg_N - ("case selector subtype is unconstrained array subtype", N); - else Check_Component_Subtype (Subtyp); end if; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index eca2abf..e4cb7e3 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -13047,7 +13047,7 @@ package body Sem_Ch12 is while Present (Index) loop Num := Num + 1; - Next_Index (Index); + Next (Index); end loop; return Num; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 228fd39..fb1be47 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Contracts; use Contracts; with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; @@ -261,6 +262,19 @@ package body Sem_Ch13 is -- Check legality of functions given in the Ada 2022 Stable_Properties -- (or Stable_Properties'Class) aspect. + procedure Validate_Storage_Model_Type_Aspect + (Typ : Entity_Id; ASN : Node_Id); + -- Check legality and completeness of the aggregate associations given in + -- the Storage_Model_Type aspect associated with Typ. + + procedure Resolve_Storage_Model_Type_Argument + (N : Node_Id; + Typ : Entity_Id; + Addr_Type : in out Entity_Id; + Nam : Name_Id); + -- Resolve argument N to be of the proper kind (when a type or constant) + -- or to have the proper profile (when a subprogram). + procedure Resolve_Aspect_Stable_Properties (Typ_Or_Subp : Entity_Id; Expr : Node_Id; @@ -860,6 +874,7 @@ package body Sem_Ch13 is if Known_Alignment (Typ) and then not Has_Alignment_Clause (Typ) + and then Present (Size) and then Size mod (Alignment (Typ) * SSU) /= 0 then Reinit_Alignment (Typ); @@ -1515,6 +1530,32 @@ package body Sem_Ch13 is when Aspect_Iterable => Validate_Iterable_Aspect (E, ASN); + when Aspect_Designated_Storage_Model => + Analyze_And_Resolve (Expression (ASN)); + + if not Is_Entity_Name (Expression (ASN)) + or else not Is_Object (Entity (Expression (ASN))) + or else + not Present (Find_Aspect (Etype (Expression (ASN)), + Aspect_Storage_Model_Type)) + then + Error_Msg_N + ("must specify name of stand-alone object of type " + & "with aspect Storage_Model_Type", + Expression (ASN)); + + -- Set access type's Associated_Storage_Pool to denote + -- the Storage_Model_Type object given for the aspect + -- (even though that isn't actually an Ada storage pool). + + else + Set_Associated_Storage_Pool + (E, Entity (Expression (ASN))); + end if; + + when Aspect_Storage_Model_Type => + Validate_Storage_Model_Type_Aspect (E, ASN); + when Aspect_Aggregate => null; @@ -2989,7 +3030,15 @@ package body Sem_Ch13 is -- Copy expression for later processing by the procedures -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations] - Set_Entity (Id, New_Copy_Tree (Expr)); + -- The expression may be a subprogram name, and can + -- be an operator name that appears as a string, but + -- requires its own analysis procedure (see sem_ch6). + + if Nkind (Expr) = N_Operator_Symbol then + Set_Entity (Id, Expr); + else + Set_Entity (Id, New_Copy_Tree (Expr)); + end if; -- Set Delay_Required as appropriate to aspect @@ -3055,10 +3104,11 @@ package body Sem_Ch13 is if Delay_Required - and then A_Id = Aspect_Stable_Properties + and then (A_Id = Aspect_Stable_Properties + or else A_Id = Aspect_Designated_Storage_Model + or else A_Id = Aspect_Storage_Model_Type) -- ??? It seems like we should do this for all aspects, not - -- just Stable_Properties, but that causes as-yet-undiagnosed - -- regressions. + -- just these, but that causes as-yet-undiagnosed regressions. then Set_Has_Delayed_Aspects (E); @@ -4358,6 +4408,44 @@ package body Sem_Ch13 is Record_Rep_Item (E, Aspect); goto Continue; + when Aspect_Designated_Storage_Model => + if not Extensions_Allowed then + Error_Msg_N + ("aspect only allowed if extensions enabled", + Aspect); + Error_Msg_N + ("\unit must be compiled with -gnatX switch", Aspect); + + elsif not Is_Type (E) + or else Ekind (E) /= E_Access_Type + then + Error_Msg_N + ("can only be specified for pool-specific access type", + Aspect); + end if; + + Record_Rep_Item (E, Aspect); + goto Continue; + + when Aspect_Storage_Model_Type => + if not Extensions_Allowed then + Error_Msg_N + ("aspect only allowed if extensions enabled", + Aspect); + Error_Msg_N + ("\unit must be compiled with -gnatX switch", Aspect); + + elsif not Is_Type (E) + or else not Is_Immutably_Limited_Type (E) + then + Error_Msg_N + ("can only be specified for immutably limited type", + Aspect); + end if; + + Record_Rep_Item (E, Aspect); + goto Continue; + when Aspect_Integer_Literal | Aspect_Real_Literal | Aspect_String_Literal @@ -4445,6 +4533,38 @@ package body Sem_Ch13 is goto Continue; end if; + -- Remember class-wide conditions; they will be merged + -- with inherited conditions. + + if Class_Present (Aspect) + and then A_Id in Aspect_Pre | Aspect_Post + and then Is_Subprogram (E) + and then not Is_Ignored_Ghost_Entity (E) + then + if A_Id = Aspect_Pre then + if Is_Ignored (Aspect) then + Set_Ignored_Class_Preconditions (E, + New_Copy_Tree (Expr)); + else + Set_Class_Preconditions (E, New_Copy_Tree (Expr)); + end if; + + -- Postconditions may split into separate aspects, and we + -- remember the expression before such split (i.e. when + -- the first postcondition is processed). + + elsif No (Class_Postconditions (E)) + and then No (Ignored_Class_Postconditions (E)) + then + if Is_Ignored (Aspect) then + Set_Ignored_Class_Postconditions (E, + New_Copy_Tree (Expr)); + else + Set_Class_Postconditions (E, New_Copy_Tree (Expr)); + end if; + end if; + end if; + -- If the expressions is of the form A and then B, then -- we generate separate Pre/Post aspects for the separate -- clauses. Since we allow multiple pragmas, there is no @@ -7125,7 +7245,7 @@ package body Sem_Ch13 is else Check_Size (Expr, U_Ent, Size, Biased); - if Size <= 0 then + if No (Size) or else Size <= 0 then Error_Msg_N ("Object_Size must be positive", Expr); elsif Is_Scalar_Type (U_Ent) then @@ -10103,7 +10223,10 @@ package body Sem_Ch13 is -- If the type is private, check whether full view has inherited -- predicates. - if Is_Private_Type (Typ) and then No (Ritem) then + if Is_Private_Type (Typ) + and then No (Ritem) + and then Present (Full_View (Typ)) + then Ritem := First_Rep_Item (Full_View (Typ)); end if; @@ -10191,6 +10314,9 @@ package body Sem_Ch13 is or else (Is_Itype (Typ) and then not Comes_From_Source (Typ) + and then Ekind (Typ) in E_Array_Subtype + | E_Record_Subtype + | E_Record_Subtype_With_Private and then Present (Predicated_Parent (Typ))) then return; @@ -11181,6 +11307,34 @@ package body Sem_Ch13 is -- Here is the list of aspects that don't require delay analysis + when Aspect_Designated_Storage_Model => + return; + + when Aspect_Storage_Model_Type => + T := Entity (ASN); + + declare + Assoc : Node_Id; + Expr : Node_Id; + Addr_Type : Entity_Id := Empty; + + begin + Assoc := First (Component_Associations (Expression (ASN))); + while Present (Assoc) loop + Expr := Expression (Assoc); + Analyze (Expr); + + if not Error_Posted (Expr) then + Resolve_Storage_Model_Type_Argument + (Expr, T, Addr_Type, Chars (First (Choices (Assoc)))); + end if; + + Next (Assoc); + end loop; + end; + + return; + when Aspect_Abstract_State | Aspect_Annotate | Aspect_Async_Readers @@ -12361,8 +12515,8 @@ package body Sem_Ch13 is end if; -- Outer level of record definition, check discriminants - -- but be careful not to flag a non-girder discriminant - -- and the girder discriminant it renames as overlapping. + -- but be careful not to flag a non-stored discriminant + -- and the stored discriminant it renames as overlapping. if Nkind (Clist) in N_Full_Type_Declaration | N_Private_Type_Declaration @@ -13162,6 +13316,13 @@ package body Sem_Ch13 is end if; end Check_Variant_Part; end if; + + if not In_Generic_Scope (E) + and then Ekind (E) = E_Record_Type + and then Is_Tagged_Type (E) + then + Process_Class_Conditions_At_Freeze_Point (E); + end if; end Freeze_Entity_Checks; ------------------------- @@ -16144,6 +16305,334 @@ package body Sem_Ch13 is Set_Analyzed (Expr); end Resolve_Aspect_Stable_Properties; + ----------------------------------------- + -- Resolve_Storage_Model_Type_Argument -- + ----------------------------------------- + + procedure Resolve_Storage_Model_Type_Argument + (N : Node_Id; + Typ : Entity_Id; + Addr_Type : in out Entity_Id; + Nam : Name_Id) + is + + type Formal_Profile is record + Subt : Entity_Id; + Mode : Formal_Kind; + end record; + + type Formal_Profiles is array (Positive range <>) of Formal_Profile; + + function Aspect_Argument_Profile_Matches + (Subp : Entity_Id; + Profiles : Formal_Profiles; + Result_Subt : Entity_Id; + Err_On_Mismatch : Boolean) return Boolean; + -- Checks that the formal parameters of subprogram Subp conform to the + -- subtypes and modes specified by Profiles, as well as to the result + -- subtype Result_Subt when that is nonempty. + + function Aspect_Argument_Profile_Matches + (Subp : Entity_Id; + Profiles : Formal_Profiles; + Result_Subt : Entity_Id; + Err_On_Mismatch : Boolean) return Boolean + is + + procedure Report_Argument_Error + (Msg : String; + Formal : Entity_Id := Empty; + Subt : Entity_Id := Empty); + -- If Err_On_Mismatch is True, reports an argument error given by Msg + -- associated with Formal and/or Subt. + + procedure Report_Argument_Error + (Msg : String; + Formal : Entity_Id := Empty; + Subt : Entity_Id := Empty) + is + begin + if Err_On_Mismatch then + if Present (Formal) then + if Present (Subt) then + Error_Msg_Node_2 := Subt; + end if; + Error_Msg_NE (Msg, N, Formal); + + elsif Present (Subt) then + Error_Msg_NE (Msg, N, Subt); + + else + Error_Msg_N (Msg, N); + end if; + end if; + end Report_Argument_Error; + + -- Local variables + + Formal : Entity_Id := First_Formal (Subp); + Is_Error : Boolean := False; + + -- Start of processing for Aspect_Argument_Profile_Matches + + begin + for FP of Profiles loop + if not Present (Formal) then + Is_Error := True; + Report_Argument_Error ("missing formal of }", Subt => FP.Subt); + exit; + + elsif not Subtypes_Statically_Match + (Etype (Formal), FP.Subt) + then + Is_Error := True; + Report_Argument_Error + ("formal& must be of subtype&", + Formal => Formal, Subt => FP.Subt); + exit; + + elsif Ekind (Formal) /= FP.Mode then + Is_Error := True; + Report_Argument_Error + ("formal& has wrong mode", Formal => Formal); + exit; + end if; + + Formal := Next_Formal (Formal); + end loop; + + if not Is_Error + and then Present (Formal) + then + Is_Error := True; + Report_Argument_Error + ("too many formals for subprogram in aspect"); + end if; + + if not Is_Error + and then Present (Result_Subt) + and then not Subtypes_Statically_Match (Etype (Subp), Result_Subt) + then + Is_Error := True; + Report_Argument_Error + ("subprogram must have result}", Subt => Result_Subt); + end if; + + return not Is_Error; + end Aspect_Argument_Profile_Matches; + + -- Local variables + + Ent : Entity_Id; + + Storage_Count_Type : constant Entity_Id := RTE (RE_Storage_Count); + System_Address_Type : constant Entity_Id := RTE (RE_Address); + + -- Start of processing for Resolve_Storage_Model_Type_Argument + + begin + if Nam = Name_Address_Type then + if not Is_Entity_Name (N) + or else not Is_Type (Entity (N)) + or else (Root_Type (Entity (N)) /= System_Address_Type + and then not Is_Integer_Type (Entity (N))) + then + Error_Msg_N ("named entity must be a descendant of System.Address " + & "or an integer type", N); + end if; + + Addr_Type := Entity (N); + + return; + + elsif not Present (Addr_Type) then + Error_Msg_N ("argument association for Address_Type missing; " + & "must be specified as first aspect argument", N); + return; + + elsif Nam = Name_Null_Address then + if not Is_Entity_Name (N) + or else not Is_Constant_Object (Entity (N)) + or else + not Subtypes_Statically_Match (Etype (Entity (N)), Addr_Type) + then + Error_Msg_NE + ("named entity must be constant of subtype}", N, Addr_Type); + end if; + + return; + + elsif not Is_Overloaded (N) then + if not Is_Entity_Name (N) + or else Ekind (Entity (N)) not in E_Function | E_Procedure + or else Scope (Entity (N)) /= Scope (Typ) + then + Error_Msg_N ("argument must be local subprogram name", N); + return; + end if; + + Ent := Entity (N); + + if Nam = Name_Allocate then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_Out_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Allocate operation", N); + end if; + + elsif Nam = Name_Deallocate then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Deallocate operation", N); + end if; + + elsif Nam = Name_Copy_From then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (System_Address_Type, E_In_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Copy_From operation", N); + end if; + + elsif Nam = Name_Copy_To then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (System_Address_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Copy_To operation", N); + end if; + + elsif Nam = Name_Storage_Size then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => (1 => (Typ, E_In_Parameter)), + Result_Subt => Storage_Count_Type, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Storage_Size operation", N); + end if; + + else + null; -- Error will be caught in Validate_Storage_Model_Type_Aspect + end if; + + else + -- Overloaded case: find subprogram with proper signature + + declare + I : Interp_Index; + It : Interp; + Found_Match : Boolean := False; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if Ekind (It.Nam) in E_Function | E_Procedure + and then Scope (It.Nam) = Scope (Typ) + then + if Nam = Name_Allocate then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_Out_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Deallocate then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Copy_From then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (System_Address_Type, E_In_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Copy_To then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (System_Address_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Storage_Size then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => (1 => (Typ, E_In_Parameter)), + Result_Subt => Storage_Count_Type, + Err_On_Mismatch => False); + end if; + + if Found_Match then + Set_Entity (N, It.Nam); + exit; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if not Found_Match then + Error_Msg_N + ("no match found for Storage_Model_Type operation", N); + end if; + end; + end if; + end Resolve_Storage_Model_Type_Argument; + ---------------- -- Set_Biased -- ---------------- @@ -16621,7 +17110,15 @@ package body Sem_Ch13 is end if; if not Overloaded and then not Present (Entity (Func_Name)) then - Analyze (Func_Name); + -- The aspect is specified by a subprogram name, which + -- may be an operator name given originally by a string. + + if Is_Operator_Name (Chars (Func_Name)) then + Analyze_Operator_Symbol (Func_Name); + else + Analyze (Func_Name); + end if; + Overloaded := Is_Overloaded (Func_Name); end if; @@ -16718,6 +17215,116 @@ package body Sem_Ch13 is end if; end Validate_Literal_Aspect; + ---------------------------------------- + -- Validate_Storage_Model_Type_Aspect -- + ---------------------------------------- + + procedure Validate_Storage_Model_Type_Aspect + (Typ : Entity_Id; ASN : Node_Id) + is + Assoc : Node_Id; + Choice : Entity_Id; + Expr : Node_Id; + + Address_Type_Id : Entity_Id := Empty; + Null_Address_Id : Entity_Id := Empty; + Allocate_Id : Entity_Id := Empty; + Deallocate_Id : Entity_Id := Empty; + Copy_From_Id : Entity_Id := Empty; + Copy_To_Id : Entity_Id := Empty; + Storage_Size_Id : Entity_Id := Empty; + + begin + -- Each expression must resolve to an entity of the right kind or proper + -- profile. + + Assoc := First (Component_Associations (Expression (ASN))); + while Present (Assoc) loop + Expr := Expression (Assoc); + Analyze (Expr); + + Choice := First (Choices (Assoc)); + + if Nkind (Choice) /= N_Identifier or else Present (Next (Choice)) then + Error_Msg_N ("illegal name in association", Choice); + + elsif Chars (Choice) = Name_Address_Type then + if Assoc /= First (Component_Associations (Expression (ASN))) then + Error_Msg_N ("Address_Type must be first association", Choice); + end if; + + Resolve_Storage_Model_Type_Argument + (Expr, Typ, Address_Type_Id, Name_Address_Type); + Address_Type_Id := Entity (Expr); + + -- Shouldn't we check for duplicates of the same subaspect name, + -- and issue an error in such cases??? + + elsif not Present (Address_Type_Id) then + Error_Msg_N + ("Address_Type missing, must be first association", Choice); + + elsif Chars (Choice) = Name_Null_Address then + Resolve_Storage_Model_Type_Argument + (Expr, Typ, Address_Type_Id, Name_Null_Address); + Null_Address_Id := Entity (Expr); + + elsif Chars (Choice) = Name_Allocate then + Resolve_Storage_Model_Type_Argument + (Expr, Typ, Address_Type_Id, Name_Allocate); + Allocate_Id := Entity (Expr); + + elsif Chars (Choice) = Name_Deallocate then + Resolve_Storage_Model_Type_Argument + (Expr, Typ, Address_Type_Id, Name_Deallocate); + Deallocate_Id := Entity (Expr); + + elsif Chars (Choice) = Name_Copy_From then + Resolve_Storage_Model_Type_Argument + (Expr, Typ, Address_Type_Id, Name_Copy_From); + Copy_From_Id := Entity (Expr); + + elsif Chars (Choice) = Name_Copy_To then + Resolve_Storage_Model_Type_Argument + (Expr, Typ, Address_Type_Id, Name_Copy_To); + Copy_To_Id := Entity (Expr); + + elsif Chars (Choice) = Name_Storage_Size then + Resolve_Storage_Model_Type_Argument + (Expr, Typ, Address_Type_Id, Name_Storage_Size); + Storage_Size_Id := Entity (Expr); + + else + Error_Msg_N + ("invalid name for Storage_Model_Type argument", Choice); + end if; + + Next (Assoc); + end loop; + + if No (Address_Type_Id) then + Error_Msg_N ("match for Address_Type not found", ASN); + + elsif No (Null_Address_Id) then + Error_Msg_N ("match for Null_Address primitive not found", ASN); + + elsif No (Allocate_Id) then + Error_Msg_N ("match for Allocate primitive not found", ASN); + + elsif No (Deallocate_Id) then + Error_Msg_N ("match for Deallocate primitive not found", ASN); + + elsif No (Copy_From_Id) then + Error_Msg_N ("match for Copy_From primitive not found", ASN); + + elsif No (Copy_To_Id) then + Error_Msg_N ("match for Copy_To primitive not found", ASN); + + elsif No (Storage_Size_Id) then + Error_Msg_N ("match for Storage_Size primitive not found", ASN); + end if; + end Validate_Storage_Model_Type_Aspect; + ----------------------------------- -- Validate_Unchecked_Conversion -- ----------------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cc8a9b7..f1a56ad 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -696,8 +696,8 @@ package body Sem_Ch3 is -- copy will leave the references to the ancestor discriminants unchanged -- in the declaration tree and they need to be fixed up. If the derived -- type has a known discriminant part, then the remapping done during the - -- copy will only create references to the girder discriminants and they - -- need to be replaced with references to the non-girder discriminants. + -- copy will only create references to the stored discriminants and they + -- need to be replaced with references to the non-stored discriminants. procedure Set_Fixed_Range (E : Entity_Id; @@ -4505,7 +4505,7 @@ package body Sem_Ch3 is -- default initial value (including via a Default_Value or -- Default_Component_Value aspect, see AI12-0301) and then this is not -- an internal declaration whose initialization comes later (as for an - -- aggregate expansion). + -- aggregate expansion) or a deferred constant. -- If expression is an aggregate it may be expanded into assignments -- and the declaration itself is marked with No_Initialization, but -- the predicate still applies. @@ -4519,6 +4519,7 @@ package body Sem_Ch3 is (Present (E) or else Is_Partially_Initialized_Type (T, Include_Implicit => False)) + and then not (Constant_Present (N) and then No (E)) then -- If the type has a static predicate and the expression is known at -- compile time, see if the expression satisfies the predicate. @@ -6253,7 +6254,7 @@ package body Sem_Ch3 is -- Move to next index - Next_Index (Index); + Next (Index); Nb_Index := Nb_Index + 1; end loop; @@ -6766,6 +6767,7 @@ package body Sem_Ch3 is Make_Procedure_Specification (Loc, Defining_Unit_Name => Subp, Parameter_Specifications => Profile); + Mutate_Ekind (Subp, E_Procedure); else Spec := Make_Function_Specification (Loc, @@ -6774,13 +6776,32 @@ package body Sem_Ch3 is Result_Definition => New_Copy_Tree (Result_Definition (Type_Definition (Decl)))); + Mutate_Ekind (Subp, E_Function); end if; New_Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); Set_Aspect_Specifications (New_Decl, Contracts); + Set_Is_Wrapper (Subp); + + -- The wrapper is declared in the freezing actions to facilitate its + -- identification and thus avoid handling it as a primitive operation + -- of a tagged type (see Is_Access_To_Subprogram_Wrapper); otherwise it + -- may be handled as a dispatching operation and erroneously registered + -- in a dispatch table. + + if not GNATprove_Mode then + Ensure_Freeze_Node (Id); + Append_Freeze_Actions (Id, New_List (New_Decl)); + + -- Under GNATprove mode there is no such problem but we do not declare + -- it in the freezing actions since they are not analyzed under this + -- mode. + + else + Insert_After (Decl, New_Decl); + end if; - Insert_After (Decl, New_Decl); Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp); Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl); end Build_Access_Subprogram_Wrapper; @@ -8475,11 +8496,11 @@ package body Sem_Ch3 is -- discriminants in R and T1 through T4: -- Type Discrim Stored Discrim Comment - -- R (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in R - -- T1 (D1, D2, D3) (D1, D2, D3) Girder discrims implicit in T1 - -- T2 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T2 - -- T3 (X1, X2) (D1, D2, D3) Girder discrims EXPLICIT in T3 - -- T4 (Y) (D1, D2, D3) Girder discrims EXPLICIT in T4 + -- R (D1, D2, D3) (D1, D2, D3) Stored discrims implicit in R + -- T1 (D1, D2, D3) (D1, D2, D3) Stored discrims implicit in T1 + -- T2 (X1, X2) (D1, D2, D3) Stored discrims EXPLICIT in T2 + -- T3 (X1, X2) (D1, D2, D3) Stored discrims EXPLICIT in T3 + -- T4 (Y) (D1, D2, D3) Stored discrims EXPLICIT in T4 -- Field Corresponding_Discriminant (abbreviated CD below) allows us to -- find the corresponding discriminant in the parent type, while @@ -15133,7 +15154,7 @@ package body Sem_Ch3 is Add_Discriminants : declare Num_Disc : Nat; - Num_Gird : Nat; + Num_Stor : Nat; begin Num_Disc := 0; @@ -15154,7 +15175,7 @@ package body Sem_Ch3 is -- the GCC 4.x back-end decides to break apart assignments between -- objects using the parent view into member-wise assignments. - Num_Gird := 0; + Num_Stor := 0; if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) @@ -15162,12 +15183,12 @@ package body Sem_Ch3 is Old_C := First_Stored_Discriminant (Typ); while Present (Old_C) loop - Num_Gird := Num_Gird + 1; + Num_Stor := Num_Stor + 1; Next_Stored_Discriminant (Old_C); end loop; end if; - if Num_Gird > Num_Disc then + if Num_Stor > Num_Disc then -- Find out multiple uses of new discriminants, and add hidden -- components for the extra renamed discriminants. We recognize @@ -16090,6 +16111,14 @@ package body Sem_Ch3 is Set_No_Return (New_Subp, No_Return (Parent_Subp)); + -- If the parent subprogram is marked as Ghost, then so is the derived + -- subprogram. The ghost policy for the derived subprogram is set from + -- the effective ghost policy at the point of derived type declaration. + + if Is_Ghost_Entity (Parent_Subp) then + Set_Is_Ghost_Entity (New_Subp); + end if; + -- A derived function with a controlling result is abstract. If the -- Derived_Type is a nonabstract formal generic derived type, then -- inherited operations are not abstract: the required check is done at @@ -19793,6 +19822,8 @@ package body Sem_Ch3 is Set_Is_Non_Static_Subtype (Def_Id); end if; end if; + + Set_Parent (Def_Id, N); end if; -- Final step is to label the index with this constructed type diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 7a8d0cc..45d2457 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1681,6 +1681,13 @@ package body Sem_Ch5 is Error_Msg_N ("(Ada 83) case expression cannot be of a generic type", Exp); return; + + elsif not Extensions_Allowed + and then not Is_Discrete_Type (Exp_Type) + then + Error_Msg_N + ("expression in case statement must be of a discrete_Type", Exp); + return; end if; -- If the case expression is a formal object of mode in out, then treat @@ -3028,6 +3035,10 @@ package body Sem_Ch5 is then Analyze_And_Resolve (Original_Bound, Typ); return Original_Bound; + + elsif Inside_Class_Condition_Preanalysis then + Analyze_And_Resolve (Original_Bound, Typ); + return Original_Bound; end if; -- Normally, the best approach is simply to generate a constant @@ -3333,11 +3344,17 @@ package body Sem_Ch5 is -- or post-condition has been expanded. Update the type of the loop -- variable to reflect the proper itype at each stage of analysis. + -- Loop_Nod might not be present when we are preanalyzing a class-wide + -- pre/postcondition since preanalysis occurs in a place unrelated to + -- the actual code and the quantified expression may be the outermost + -- expression of the class-wide condition. + if No (Etype (Id)) or else Etype (Id) = Any_Type or else (Present (Etype (Id)) and then Is_Itype (Etype (Id)) + and then Present (Loop_Nod) and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions and then Nkind (Original_Node (Parent (Loop_Nod))) = N_Quantified_Expression) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 304dc19..e32c4ad 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -385,15 +385,9 @@ package body Sem_Ch6 is Analyze (New_Body); Set_Is_Inlined (Prev); - -- If the expression function is a completion, the previous declaration - -- must come from source. We know already that it appears in the current - -- scope. The entity itself may be internally created if within a body - -- to be inlined. - elsif Present (Prev) and then Is_Overloadable (Prev) and then not Is_Formal_Subprogram (Prev) - and then Comes_From_Source (Parent (Prev)) then Set_Has_Completion (Prev, False); Set_Is_Inlined (Prev); @@ -2132,8 +2126,15 @@ package body Sem_Ch6 is and then Attribute_Name (Par) /= Name_Value) or else (Nkind (Maybe_Aspect_Spec) = N_Aspect_Specification and then Get_Aspect_Id (Maybe_Aspect_Spec) - -- include other aspects here ??? - in Aspect_Stable_Properties | Aspect_Aggregate) + + -- Include aspects that can be specified by a + -- subprogram name, which can be an operator. + + in Aspect_Stable_Properties + | Aspect_Integer_Literal + | Aspect_Real_Literal + | Aspect_String_Literal + | Aspect_Aggregate) then Find_Direct_Name (N); @@ -4504,29 +4505,6 @@ package body Sem_Ch6 is end if; end if; - -- If the subprogram has a class-wide clone, build its body as a copy - -- of the original body, and rewrite body of original subprogram as a - -- wrapper that calls the clone. If N is a stub, this construction will - -- take place when the proper body is analyzed. No action needed if this - -- subprogram has been eliminated. - - if Present (Spec_Id) - and then Present (Class_Wide_Clone (Spec_Id)) - and then (Comes_From_Source (N) or else Was_Expression_Function (N)) - and then Nkind (N) /= N_Subprogram_Body_Stub - and then not (Expander_Active and then Is_Eliminated (Spec_Id)) - then - Build_Class_Wide_Clone_Body (Spec_Id, N); - - -- This is the new body for the existing primitive operation - - Rewrite (N, Build_Class_Wide_Clone_Call - (Sloc (N), New_List, Spec_Id, Parent (Spec_Id))); - Set_Has_Completion (Spec_Id, False); - Analyze (N); - return; - end if; - -- Place subprogram on scope stack, and make formals visible. If there -- is a spec, the visible entity remains that of the spec. @@ -7760,7 +7738,7 @@ package body Sem_Ch6 is ("RETURN statement missing following this statement<<!", Last_Stm); Error_Msg_N - ("\Program_Error ]<<!", Last_Stm); + ("\Program_Error [<<!", Last_Stm); end if; -- Note: we set Err even though we have not issued a warning @@ -9480,13 +9458,12 @@ package body Sem_Ch6 is end if; -- Here if type is not frozen yet. It is illegal to have a primitive - -- equality declared in the private part if the type is visible. + -- equality declared in the private part if the type is visible + -- (RM 4.5.2(9.8)). elsif not In_Same_List (Parent (Typ), Decl) and then not Is_Limited_Type (Typ) then - -- Shouldn't we give an RM reference here??? - if Ada_Version >= Ada_2012 then Error_Msg_N ("equality operator appears too late<<", Eq_Op); @@ -9817,7 +9794,8 @@ package body Sem_Ch6 is -- conform when they do not, e.g. by converting 1+2 into 3. function FCE (Given_E1 : Node_Id; Given_E2 : Node_Id) return Boolean; - -- ??? + -- Convenience function to abbreviate recursive calls to + -- Fully_Conformant_Expressions without having to pass Report. function FCL (L1 : List_Id; L2 : List_Id) return Boolean; -- Compare elements of two lists for conformance. Elements have to be @@ -10419,6 +10397,7 @@ package body Sem_Ch6 is begin Set_Is_Immediately_Visible (E); Set_Current_Entity (E); + pragma Assert (Prev /= E); Set_Homonym (E, Prev); end Install_Entity; @@ -10778,7 +10757,7 @@ package body Sem_Ch6 is Error_Msg_Node_2 := F_Typ; Error_Msg_NE ("private operation& in generic unit does not override " - & "any primitive operation of& (RM 12.3 (18))??", + & "any primitive operation of& (RM 12.3(18))??", New_E, New_E); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 095bcda..3852a9a 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1768,19 +1768,34 @@ package body Sem_Ch7 is end if; -- Check preelaborable initialization for full type completing a - -- private type when aspect Preelaborable_Initialization is True. - -- We pass True for the parameter Formal_Types_Have_Preelab_Init - -- to take into account the rule that presumes that subcomponents - -- of generic formal types mentioned in the type's P_I aspect have - -- preelaborable initialization (see RM 10.2.1(11.8/5)). - - if Is_Type (E) - and then Must_Have_Preelab_Init (E) - and then not Has_Preelaborable_Initialization - (E, Formal_Types_Have_Preelab_Init => True) - then - Error_Msg_N - ("full view of & does not have preelaborable initialization", E); + -- private type when aspect Preelaborable_Initialization is True + -- or is specified by Preelaborable_Initialization attributes + -- (in the case of a private type in a generic unit). We pass + -- the expression of the aspect (when present) to the parameter + -- Preelab_Init_Expr to take into account the rule that presumes + -- that subcomponents of generic formal types mentioned in the + -- type's P_I aspect have preelaborable initialization (see + -- AI12-0409 and RM 10.2.1(11.8/5)). + + if Is_Type (E) and then Must_Have_Preelab_Init (E) then + declare + PI_Aspect : constant Node_Id := + Find_Aspect + (E, Aspect_Preelaborable_Initialization); + PI_Expr : Node_Id := Empty; + begin + if Present (PI_Aspect) then + PI_Expr := Expression (PI_Aspect); + end if; + + if not Has_Preelaborable_Initialization + (E, Preelab_Init_Expr => PI_Expr) + then + Error_Msg_N + ("full view of & does not have " + & "preelaborable initialization", E); + end if; + end; end if; Next_Entity (E); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index a9f0f13..494ec64 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -426,12 +426,10 @@ package body Sem_Ch8 is -- body at the point of freezing will not work. Subp is the subprogram -- for which N provides the Renaming_As_Body. - procedure Check_In_Previous_With_Clause - (N : Node_Id; - Nam : Node_Id); + procedure Check_In_Previous_With_Clause (N, Nam : Node_Id); -- N is a use_package clause and Nam the package name, or N is a use_type -- clause and Nam is the prefix of the type name. In either case, verify - -- that the package is visible at that point in the context: either it + -- that the package is visible at that point in the context: either it -- appears in a previous with_clause, or because it is a fully qualified -- name and the root ancestor appears in a previous with_clause. @@ -2541,8 +2539,8 @@ package body Sem_Ch8 is and then Is_Class_Wide_Type (Get_Instance_Of (Etype (Formal))) then Formal_Typ := Etype (Formal); - Actual_Typ := Get_Instance_Of (Formal_Typ); - Root_Typ := Etype (Actual_Typ); + Actual_Typ := Base_Type (Get_Instance_Of (Formal_Typ)); + Root_Typ := Root_Type (Actual_Typ); exit; end if; @@ -2592,6 +2590,15 @@ package body Sem_Ch8 is elsif CW_Prim_Op = Root_Prim_Op then Prim_Op := Root_Prim_Op; + -- The two subprograms are legal but the class-wide subprogram is + -- a class-wide wrapper built for a previous instantiation; the + -- wrapper has precedence. + + elsif Present (Alias (CW_Prim_Op)) + and then Is_Class_Wide_Wrapper (Ultimate_Alias (CW_Prim_Op)) + then + Prim_Op := CW_Prim_Op; + -- Otherwise both candidate subprograms are user-defined and -- ambiguous. @@ -2690,6 +2697,8 @@ package body Sem_Ch8 is Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); end if; + Set_Is_Class_Wide_Wrapper (Wrap_Id); + -- If the operator carries an Eliminated pragma, indicate that the -- wrapper is also to be eliminated, to prevent spurious error when -- using gnatelim on programs that include box-initialization of @@ -4670,10 +4679,7 @@ package body Sem_Ch8 is -- Check_In_Previous_With_Clause -- ----------------------------------- - procedure Check_In_Previous_With_Clause - (N : Node_Id; - Nam : Entity_Id) - is + procedure Check_In_Previous_With_Clause (N, Nam : Node_Id) is Pack : constant Entity_Id := Entity (Original_Node (Nam)); Item : Node_Id; Par : Node_Id; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 064e2b5..cba3c9d 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -32,9 +32,11 @@ with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Exp_Disp; use Exp_Disp; with Exp_Util; use Exp_Util; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Errout; use Errout; +with Freeze; use Freeze; with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; @@ -197,6 +199,91 @@ package body Sem_Disp is return Empty; end Covered_Interface_Op; + ---------------------------------- + -- Covered_Interface_Primitives -- + ---------------------------------- + + function Covered_Interface_Primitives (Prim : Entity_Id) return Elist_Id is + Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim); + Elmt : Elmt_Id; + E : Entity_Id; + Result : Elist_Id := No_Elist; + + begin + pragma Assert (Is_Dispatching_Operation (Prim)); + + -- Although this is a dispatching primitive we must check if its + -- dispatching type is available because it may be the primitive + -- of a private type not defined as tagged in its partial view. + + if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then + + -- If the tagged type is frozen then the internal entities associated + -- with interfaces are available in the list of primitives of the + -- tagged type and can be used to speed up this search. + + if Is_Frozen (Tagged_Type) then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + E := Node (Elmt); + + if Present (Interface_Alias (E)) + and then Alias (E) = Prim + then + if No (Result) then + Result := New_Elmt_List; + end if; + + Append_Elmt (Interface_Alias (E), Result); + end if; + + Next_Elmt (Elmt); + end loop; + + -- Otherwise we must collect all the interface primitives and check + -- whether the Prim overrides (implements) some interface primitive. + + else + declare + Ifaces_List : Elist_Id; + Iface_Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Prim : Entity_Id; + + begin + Collect_Interfaces (Tagged_Type, Ifaces_List); + + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); + + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); + + if Chars (Iface_Prim) = Chars (Prim) + and then Is_Interface_Conformant + (Tagged_Type, Iface_Prim, Prim) + then + if No (Result) then + Result := New_Elmt_List; + end if; + + Append_Elmt (Iface_Prim, Result); + end if; + + Next_Elmt (Elmt); + end loop; + + Next_Elmt (Iface_Elmt); + end loop; + end; + end if; + end if; + + return Result; + end Covered_Interface_Primitives; + ------------------------------- -- Check_Controlling_Formals -- ------------------------------- @@ -592,6 +679,14 @@ package body Sem_Disp is -- Start of processing for Check_Dispatching_Context begin + -- Skip checking context of dispatching calls during preanalysis of + -- class-wide conditions since at that stage the expression is not + -- installed yet on its definite context. + + if Inside_Class_Condition_Preanalysis then + return; + end if; + -- If the called subprogram is a private overriding, replace it -- with its alias, which has the correct body. Verify that the -- two subprograms have the same controlling type (this is not the @@ -992,10 +1087,17 @@ package body Sem_Disp is -- nonstatic values, then report an error. This is specified by -- RM 6.1.1(18.2/5) (by AI12-0412). + -- Skip reporting this error on helpers and indirect-call wrappers + -- built to support class-wide preconditions. + if No (Control) and then not Is_Abstract_Subprogram (Subp_Entity) and then Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Subp_Entity) + and then not + (Is_Subprogram (Current_Scope) + and then + Present (Class_Preconditions_Subprogram (Current_Scope))) then Error_Msg_N ("nondispatching call to nonabstract subprogram of " @@ -1018,6 +1120,9 @@ package body Sem_Disp is --------------------------------- procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is + function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean; + -- Return True if E is an access to subprogram wrapper + procedure Warn_On_Late_Primitive_After_Private_Extension (Typ : Entity_Id; Prim : Entity_Id); @@ -1025,6 +1130,22 @@ package body Sem_Disp is -- if it is a public primitive defined after some private extension of -- the tagged type. + ------------------------------------- + -- Is_Access_To_Subprogram_Wrapper -- + ------------------------------------- + + function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean + is + Decl_N : constant Node_Id := Unit_Declaration_Node (E); + Par_N : constant Node_Id := Parent (List_Containing (Decl_N)); + + begin + -- Access to subprogram wrappers are declared in the freezing actions + + return Nkind (Par_N) = N_Freeze_Entity + and then Ekind (Entity (Par_N)) = E_Access_Subprogram_Type; + end Is_Access_To_Subprogram_Wrapper; + ---------------------------------------------------- -- Warn_On_Late_Primitive_After_Private_Extension -- ---------------------------------------------------- @@ -1095,6 +1216,13 @@ package body Sem_Disp is or else Is_Partial_Invariant_Procedure (Subp) then return; + + -- Wrappers of access to subprograms are not primitive subprograms. + + elsif Is_Wrapper (Subp) + and then Is_Access_To_Subprogram_Wrapper (Subp) + then + return; end if; Set_Is_Dispatching_Operation (Subp, False); @@ -1407,7 +1535,39 @@ package body Sem_Disp is Generate_Reference (Tagged_Type, Subp, 'P', False); Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp); + Set_Is_Dispatching_Operation (Subp); + + -- Inherit decoration of controlling formals and + -- controlling result. + + if Ekind (Old_Subp) = E_Function + and then Has_Controlling_Result (Old_Subp) + then + Set_Has_Controlling_Result (Subp); + end if; + + if Present (First_Formal (Old_Subp)) then + declare + Old_Formal : Entity_Id; + Formal : Entity_Id; + + begin + Formal := First_Formal (Subp); + Old_Formal := First_Formal (Old_Subp); + + while Present (Old_Formal) loop + Set_Is_Controlling_Formal (Formal, + Is_Controlling_Formal (Old_Formal)); + + Next_Formal (Formal); + Next_Formal (Old_Formal); + end loop; + end; + end if; end if; + + Check_Inherited_Conditions (Tagged_Type, + Late_Overriding => True); end if; end if; end; @@ -2420,12 +2580,27 @@ package body Sem_Disp is if No (Tag_Typ) then return Result (1 .. 0); + + -- Prevent cascaded errors + + elsif Is_Concurrent_Type (Tag_Typ) + and then No (Corresponding_Record_Type (Tag_Typ)) + and then Serious_Errors_Detected > 0 + then + return Result (1 .. 0); end if; if Is_Concurrent_Type (Tag_Typ) then Tag_Typ := Corresponding_Record_Type (Tag_Typ); end if; + if Present (Tag_Typ) + and then Is_Private_Type (Tag_Typ) + and then Present (Full_View (Tag_Typ)) + then + Tag_Typ := Full_View (Tag_Typ); + end if; + -- Search primitive operations of dispatching type if Present (Tag_Typ) @@ -2855,6 +3030,11 @@ package body Sem_Disp is Next_Actual (Arg); end loop; + -- Add class-wide precondition check if the target of this dispatching + -- call has or inherits class-wide preconditions. + + Install_Class_Preconditions_Check (Call_Node); + -- Expansion of dispatching calls is suppressed on VM targets, because -- the VM back-ends directly handle the generation of dispatching calls -- and would have to undo any expansion to an indirect call. diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index 7b42cf5..f37391b 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -74,6 +74,10 @@ package Sem_Disp is -- The Alias of Old_Subp is adjusted to point to the inherited procedure -- of the full view because it is always this one which has to be called. + function Covered_Interface_Primitives (Prim : Entity_Id) return Elist_Id; + -- Returns all the interface primitives covered by Prim, when its + -- controlling type has progenitors. + function Covered_Interface_Op (Prim : Entity_Id) return Entity_Id; -- Returns the interface primitive that Prim covers, when its controlling -- type has progenitors. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index f6edcac..122a837 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2070,7 +2070,7 @@ package body Sem_Elab is -- Change the status of the elaboration phase of the compiler to Status procedure Spec_And_Body_From_Entity - (Id : Node_Id; + (Id : Entity_Id; Spec_Decl : out Node_Id; Body_Decl : out Node_Id); pragma Inline (Spec_And_Body_From_Entity); @@ -13621,6 +13621,13 @@ package body Sem_Elab is then return True; + -- A call to an expression function that is not a completion cannot + -- cause an ABE because it has no prior declaration; this remains + -- true even if the FE transforms the callee into something else. + + elsif Nkind (Original_Node (Spec_Decl)) = N_Expression_Function then + return True; + -- Subprogram bodies which wrap attribute references used as actuals -- in instantiations are always ABE-safe. These bodies are artifacts -- of expansion. @@ -15835,7 +15842,7 @@ package body Sem_Elab is ------------------------------- procedure Spec_And_Body_From_Entity - (Id : Node_Id; + (Id : Entity_Id; Spec_Decl : out Node_Id; Body_Decl : out Node_Id) is diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 6f81406..20bc03a 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -118,7 +118,8 @@ package body Sem_Eval is subtype CV_Range is Nat range 0 .. CV_Cache_Size; type CV_Entry is record - N : Node_Id; + N : Node_Id'Base; + -- We use 'Base here, in case we want to add a predicate to Node_Id V : Uint; end record; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9cad55d..0163ff9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -9532,7 +9532,11 @@ package body Sem_Prag is Process_Import_Predefined_Type; - else + -- Emit an error unless Relaxed_RM_Semantics since some legacy Ada + -- compilers may accept more cases, e.g. JGNAT allowed importing + -- a Java package. + + elsif not Relaxed_RM_Semantics then if From_Aspect_Specification (N) then Error_Pragma_Arg ("entity for aspect% must be object, subprogram " @@ -14202,6 +14206,16 @@ package body Sem_Prag is when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning => GNAT_Pragma; + + -- These pragmas rely on the context. In adc files they raise + -- Constraint_Error. Ban them from use as configuration pragmas + -- even in cases where such a use could work. + + if Is_Configuration_Pragma then + Error_Pragma + ("pragma% is not allowed as a configuration pragma"); + end if; + Process_Compile_Time_Warning_Or_Error; --------------------------- @@ -14835,9 +14849,41 @@ package body Sem_Prag is & "effect?j?", N); end if; - -------------------- + ----------------- + -- CUDA_Device -- + ----------------- + + when Pragma_CUDA_Device => CUDA_Device : declare + Arg_Node : Node_Id; + Device_Entity : Entity_Id; + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Arg_Is_Library_Level_Local_Name (Arg1); + + Arg_Node := Get_Pragma_Arg (Arg1); + Device_Entity := Entity (Arg_Node); + + if Ekind (Device_Entity) in E_Variable + | E_Constant + | E_Procedure + | E_Function + then + Add_CUDA_Device_Entity + (Package_Specification_Of_Scope (Scope (Device_Entity)), + Device_Entity); + + else + Error_Msg_NE ("& must be constant, variable or subprogram", + N, + Device_Entity); + end if; + + end CUDA_Device; + + ------------------ -- CUDA_Execute -- - -------------------- + ------------------ -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT, -- EXPRESSION, @@ -25892,23 +25938,6 @@ package body Sem_Prag is ("operation in class-wide condition must be primitive " & "of &", Nod, Disp_Typ); end if; - - -- Otherwise we have a call to an overridden primitive, and we - -- will create a common class-wide clone for the body of - -- original operation and its eventual inherited versions. If - -- the original operation dispatches on result it is never - -- inherited and there is no need for a clone. There is not - -- need for a clone either in GNATprove mode, as cases that - -- would require it are rejected (when an inherited primitive - -- calls an overridden operation in a class-wide contract), and - -- the clone would make proof impossible in some cases. - - elsif not Is_Abstract_Subprogram (Spec_Id) - and then No (Class_Wide_Clone (Spec_Id)) - and then not Has_Controlling_Result (Spec_Id) - and then not GNATprove_Mode - then - Build_Class_Wide_Clone_Decl (Spec_Id); end if; end; @@ -26029,15 +26058,6 @@ package body Sem_Prag is End_Scope; end if; - -- If analysis of the condition indicates that a class-wide clone - -- has been created, build and analyze its declaration. - - if Is_Subprogram (Spec_Id) - and then Present (Class_Wide_Clone (Spec_Id)) - then - Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id))); - end if; - -- Currently it is not possible to inline pre/postconditions on a -- subprogram subject to pragma Inline_Always. @@ -29524,9 +29544,6 @@ package body Sem_Prag is Msg_Arg : Node_Id; Nam : Name_Id; - Needs_Wrapper : Boolean; - pragma Unreferenced (Needs_Wrapper); - -- Start of processing for Build_Pragma_Check_Equivalent begin @@ -29553,11 +29570,10 @@ package body Sem_Prag is -- Build the inherited class-wide condition Build_Class_Wide_Expression - (Prag => Check_Prag, - Subp => Subp_Id, - Par_Subp => Inher_Id, - Adjust_Sloc => True, - Needs_Wrapper => Needs_Wrapper); + (Pragma_Or_Expr => Check_Prag, + Subp => Subp_Id, + Par_Subp => Inher_Id, + Adjust_Sloc => True); -- If not an inherited condition simply copy the original pragma @@ -31274,6 +31290,7 @@ package body Sem_Prag is Pragma_C_Pass_By_Copy => 0, Pragma_Comment => -1, Pragma_Common_Object => 0, + Pragma_CUDA_Device => -1, Pragma_CUDA_Execute => -1, Pragma_CUDA_Global => -1, Pragma_Compile_Time_Error => -1, diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index e166481..fed24fd 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -49,6 +49,7 @@ package Sem_Prag is Pragma_Contract_Cases => True, Pragma_Convention => True, Pragma_CPU => True, + Pragma_CUDA_Device => True, Pragma_CUDA_Global => True, Pragma_Default_Initial_Condition => True, Pragma_Default_Storage_Pool => True, @@ -429,7 +430,7 @@ package Sem_Prag is function Get_Argument (Prag : Node_Id; - Context_Id : Node_Id := Empty) return Node_Id; + Context_Id : Entity_Id := Empty) return Node_Id; -- Obtain the argument of pragma Prag depending on context and the nature -- of the pragma. The argument is extracted in the following manner: -- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 12b3295..0bdc463 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2920,6 +2920,16 @@ package body Sem_Res is Expr : Node_Id; begin + if Is_Derived_Type (Typ) + and then Is_Tagged_Type (Typ) + and then Base_Type (Etype (Callee)) /= Base_Type (Typ) + then + Callee := + Corresponding_Primitive_Op + (Ancestor_Op => Callee, + Descendant_Type => Base_Type (Typ)); + end if; + if Nkind (N) = N_Identifier then Expr := Expression (Declaration_Node (Entity (N))); @@ -2990,16 +3000,23 @@ package body Sem_Res is Set_Etype (Call, Etype (Callee)); - -- Conversion needed in case of an inherited aspect - -- of a derived type. - -- - -- ??? Need to do something different here for downward - -- tagged conversion case (which is only possible in the - -- case of a null extension); the current call to - -- Convert_To results in an error message about an illegal - -- downward conversion. + if Base_Type (Etype (Call)) /= Base_Type (Typ) then + -- Conversion may be needed in case of an inherited + -- aspect of a derived type. For a null extension, we + -- use a null extension aggregate instead because the + -- downward type conversion would be illegal. - Call := Convert_To (Typ, Call); + if Is_Null_Extension_Of + (Descendant => Typ, + Ancestor => Etype (Call)) + then + Call := Make_Extension_Aggregate (Loc, + Ancestor_Part => Call, + Null_Record_Present => True); + else + Call := Convert_To (Typ, Call); + end if; + end if; Rewrite (N, Call); end; @@ -3081,6 +3098,24 @@ package body Sem_Res is Error_Msg_N ("\use -gnatf for details", N); end if; + -- Recognize the case of a quantified expression being mistaken + -- for an iterated component association because the user + -- forgot the "all" or "some" keyword after "for". Because the + -- error message starts with "missing ALL", we automatically + -- benefit from the associated CODEFIX, which requires that + -- the message is located on the identifier following "for" + -- in order for the CODEFIX to insert "all" in the right place. + + elsif Nkind (N) = N_Aggregate + and then List_Length (Component_Associations (N)) = 1 + and then Nkind (First (Component_Associations (N))) + = N_Iterated_Component_Association + and then Is_Boolean_Type (Typ) + then + Error_Msg_N -- CODEFIX + ("missing ALL or SOME in quantified expression", + Defining_Identifier (First (Component_Associations (N)))); + else Wrong_Type (N, Typ); end if; @@ -4874,10 +4909,15 @@ package body Sem_Res is -- Apply legality rule 3.9.2 (9/1) + -- Skip this check on helpers and indirect-call wrappers built to + -- support class-wide preconditions. + if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) and then not Is_Class_Wide_Type (F_Typ) and then not Is_Controlling_Formal (F) and then not In_Instance + and then (not Is_Subprogram (Nam) + or else No (Class_Preconditions_Subprogram (Nam))) then Error_Msg_N ("class-wide argument not allowed here!", A); @@ -4975,9 +5015,13 @@ package body Sem_Res is -- "False" cannot act as an actual in a subprogram with value -- "True" (SPARK RM 6.1.7(3)). + -- No check needed for helpers and indirect-call wrappers built to + -- support class-wide preconditions. + if Is_EVF_Expression (A) and then Extensions_Visible_Status (Nam) = Extensions_Visible_True + and then No (Class_Preconditions_Subprogram (Current_Scope)) then Error_Msg_N ("formal parameter cannot act as actual parameter when " @@ -7461,66 +7505,76 @@ package body Sem_Res is (N : Node_Id; Typ : Entity_Id) is - Decl : Node_Id; - Need_Transient_Scope : Boolean := False; - begin - -- 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. + Expr : constant Node_Id := Expression (N); - Decl := First (Actions (N)); - while Present (Decl) loop - exit when Nkind (Decl) - in N_Object_Declaration | N_Object_Renaming_Declaration; - Next (Decl); - end loop; + Decl : Node_Id; + Local : Entity_Id := Empty; - if Present (Decl) then + function Replace_Local (N : Node_Id) return Traverse_Result; + -- Use a tree traversal to replace each ocurrence of the name of + -- a local object declared in the construct, with the corresponding + -- entity. This replaces the usual way to perform name capture by + -- visibility, because it is not possible to place on the scope + -- stack the fake scope created for the analysis of the local + -- declarations; such a scope conflicts with the transient scopes + -- that may be generated if the expression includes function calls + -- requiring finalization. - -- Need to establish a transient scope in case Expression (N) - -- requires actions to be wrapped. + ------------------- + -- Replace_Local -- + ------------------- - declare - Node : Node_Id; - begin - Node := First (Actions (N)); - while Present (Node) loop - if Nkind (Node) = N_Object_Declaration - and then Requires_Transient_Scope - (Etype (Defining_Identifier (Node))) - then - Need_Transient_Scope := True; - exit; - end if; + function Replace_Local (N : Node_Id) return Traverse_Result is + begin + -- The identifier may be the prefix of a selected component, + -- but not a selector name, because the local entities do not + -- have a scope that can be named: a selected component whose + -- selector is a homonym of a local entity must denote some + -- global entity. + + if Nkind (N) = N_Identifier + and then Chars (N) = Chars (Local) + and then No (Entity (N)) + and then + (Nkind (Parent (N)) /= N_Selected_Component + or else N = Prefix (Parent (N))) + then + Set_Entity (N, Local); + Set_Etype (N, Etype (Local)); + end if; - Next (Node); - end loop; - end; + return OK; + end Replace_Local; - if Need_Transient_Scope then - Establish_Transient_Scope (Decl, Manage_Sec_Stack => True); - else - Push_Scope (Scope (Defining_Identifier (Decl))); + procedure Replace_Local_Ref is new Traverse_Proc (Replace_Local); + + -- Start of processing for Resolve_Declare_Expression + + begin + + Decl := First (Actions (N)); + + while Present (Decl) loop + if Nkind (Decl) in + N_Object_Declaration | N_Object_Renaming_Declaration + and then Comes_From_Source (Defining_Identifier (Decl)) + then + Local := Defining_Identifier (Decl); + Replace_Local_Ref (Expr); end if; - declare - E : Entity_Id := First_Entity (Current_Scope); - begin - while Present (E) loop - Set_Current_Entity (E); - Set_Is_Immediately_Visible (E); - Next_Entity (E); - end loop; - end; + Next (Decl); + end loop; - Resolve (Expression (N), Typ); - End_Scope; + -- The end of the declarative list is a freeze point for the + -- local declarations. - else - Resolve (Expression (N), Typ); + if Present (Local) then + Decl := Parent (Local); + Freeze_All (First_Entity (Scope (Local)), Decl); end if; + + Resolve (Expr, Typ); end Resolve_Declare_Expression; ----------------------------------------- @@ -9217,7 +9271,7 @@ package body Sem_Res is ------------------------------- procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is - Name : constant Node_Id := Prefix (N); + Pref : constant Node_Id := Prefix (N); Expr : Node_Id; Array_Type : Entity_Id := Empty; -- to prevent junk warning Index : Node_Id; @@ -9228,7 +9282,7 @@ package body Sem_Res is return; end if; - if Is_Overloaded (Name) then + if Is_Overloaded (Pref) then -- Use the context type to select the prefix that yields the correct -- component type. @@ -9237,11 +9291,10 @@ package body Sem_Res is I : Interp_Index; It : Interp; I1 : Interp_Index := 0; - P : constant Node_Id := Prefix (N); Found : Boolean := False; begin - Get_First_Interp (P, I, It); + Get_First_Interp (Pref, I, It); while Present (It.Typ) loop if (Is_Array_Type (It.Typ) and then Covers (Typ, Component_Type (It.Typ))) @@ -9253,7 +9306,7 @@ package body Sem_Res is Component_Type (Designated_Type (It.Typ)))) then if Found then - It := Disambiguate (P, I1, I, Any_Type); + It := Disambiguate (Pref, I1, I, Any_Type); if It = No_Interp then Error_Msg_N ("ambiguous prefix for indexing", N); @@ -9278,11 +9331,11 @@ package body Sem_Res is end; else - Array_Type := Etype (Name); + Array_Type := Etype (Pref); end if; - Resolve (Name, Array_Type); - Array_Type := Get_Actual_Subtype_If_Available (Name); + Resolve (Pref, Array_Type); + Array_Type := Get_Actual_Subtype_If_Available (Pref); -- If the prefix's type is an access type, get to the real array type. -- Note: we do not apply an access check because an explicit dereference @@ -9325,19 +9378,18 @@ package body Sem_Res is end loop; end if; - Resolve_Implicit_Dereference (Prefix (N)); + Resolve_Implicit_Dereference (Pref); Analyze_Dimension (N); -- Do not generate the warning on suspicious index if we are analyzing -- package Ada.Tags; otherwise we will report the warning with the -- Prims_Ptr field of the dispatch table. - if Scope (Etype (Prefix (N))) = Standard_Standard + if Scope (Etype (Pref)) = Standard_Standard or else not - Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))), - Ada_Tags) + Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Pref))), Ada_Tags) then - Warn_On_Suspicious_Index (Name, First (Expressions (N))); + Warn_On_Suspicious_Index (Pref, First (Expressions (N))); Eval_Indexed_Component (N); end if; @@ -9349,16 +9401,16 @@ package body Sem_Res is if Nkind (N) = N_Indexed_Component and then Is_Atomic_Ref_With_Address (N) and then not (Has_Atomic_Components (Array_Type) - or else (Is_Entity_Name (Prefix (N)) + or else (Is_Entity_Name (Pref) and then Has_Atomic_Components - (Entity (Prefix (N))))) + (Entity (Pref)))) and then not Is_Atomic (Component_Type (Array_Type)) and then Ada_Version < Ada_2022 then Error_Msg_N - ("??access to non-atomic component of atomic array", Prefix (N)); + ("??access to non-atomic component of atomic array", Pref); Error_Msg_N - ("??\may cause unexpected accesses to atomic object", Prefix (N)); + ("??\may cause unexpected accesses to atomic object", Pref); end if; end Resolve_Indexed_Component; @@ -11166,13 +11218,13 @@ package body Sem_Res is procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is Drange : constant Node_Id := Discrete_Range (N); - Name : constant Node_Id := Prefix (N); + Pref : constant Node_Id := Prefix (N); Array_Type : Entity_Id := Empty; Dexpr : Node_Id := Empty; Index_Type : Entity_Id; begin - if Is_Overloaded (Name) then + if Is_Overloaded (Pref) then -- Use the context type to select the prefix that yields the correct -- array type. @@ -11181,11 +11233,10 @@ package body Sem_Res is I : Interp_Index; I1 : Interp_Index := 0; It : Interp; - P : constant Node_Id := Prefix (N); Found : Boolean := False; begin - Get_First_Interp (P, I, It); + Get_First_Interp (Pref, I, It); while Present (It.Typ) loop if (Is_Array_Type (It.Typ) and then Covers (Typ, It.Typ)) @@ -11194,7 +11245,7 @@ package body Sem_Res is and then Covers (Typ, Designated_Type (It.Typ))) then if Found then - It := Disambiguate (P, I1, I, Any_Type); + It := Disambiguate (Pref, I1, I, Any_Type); if It = No_Interp then Error_Msg_N ("ambiguous prefix for slicing", N); @@ -11217,10 +11268,10 @@ package body Sem_Res is end; else - Array_Type := Etype (Name); + Array_Type := Etype (Pref); end if; - Resolve (Name, Array_Type); + Resolve (Pref, Array_Type); -- If the prefix's type is an access type, get to the real array type. -- Note: we do not apply an access check because an explicit dereference @@ -11236,12 +11287,12 @@ package body Sem_Res is -- subtype. if not Is_Constrained (Array_Type) then - Remove_Side_Effects (Prefix (N)); + Remove_Side_Effects (Pref); declare Obj : constant Node_Id := Make_Explicit_Dereference (Sloc (N), - Prefix => New_Copy_Tree (Prefix (N))); + Prefix => New_Copy_Tree (Pref)); begin Set_Etype (Obj, Array_Type); Set_Parent (Obj, Parent (N)); @@ -11249,25 +11300,35 @@ package body Sem_Res is end; end if; - elsif Is_Entity_Name (Name) - or else Nkind (Name) = N_Explicit_Dereference - or else (Nkind (Name) = N_Function_Call - and then not Is_Constrained (Etype (Name))) + -- In CodePeer mode the attribute Image is not expanded, so when it + -- acts as a prefix of a slice, we handle it like a call to function + -- returning an unconstrained string. Same for the Wide variants of + -- attribute Image. + + elsif Is_Entity_Name (Pref) + or else Nkind (Pref) = N_Explicit_Dereference + or else (Nkind (Pref) = N_Function_Call + and then not Is_Constrained (Etype (Pref))) + or else (CodePeer_Mode + and then Nkind (Pref) = N_Attribute_Reference + and then Attribute_Name (Pref) in Name_Image + | Name_Wide_Image + | Name_Wide_Wide_Image) then - Array_Type := Get_Actual_Subtype (Name); + Array_Type := Get_Actual_Subtype (Pref); -- If the name is a selected component that depends on discriminants, -- build an actual subtype for it. This can happen only when the name -- itself is overloaded; otherwise the actual subtype is created when -- the selected component is analyzed. - elsif Nkind (Name) = N_Selected_Component + elsif Nkind (Pref) = N_Selected_Component and then Full_Analysis and then Depends_On_Discriminant (First_Index (Array_Type)) then declare Act_Decl : constant Node_Id := - Build_Actual_Subtype_Of_Component (Array_Type, Name); + Build_Actual_Subtype_Of_Component (Array_Type, Pref); begin Insert_Action (N, Act_Decl); Array_Type := Defining_Identifier (Act_Decl); @@ -11280,8 +11341,8 @@ package body Sem_Res is -- check applied below (the range check won't get done if the -- unconstrained subtype of the 'Image is used). - elsif Nkind (Name) = N_Slice then - Array_Type := Etype (Name); + elsif Nkind (Pref) = N_Slice then + Array_Type := Etype (Pref); end if; -- Obtain the type of the array index @@ -11304,27 +11365,32 @@ package body Sem_Res is if Tagged_Type_Expansion and then RTU_Loaded (Ada_Tags) - and then Nkind (Prefix (N)) = N_Selected_Component - and then Present (Entity (Selector_Name (Prefix (N)))) - and then Entity (Selector_Name (Prefix (N))) = + and then Nkind (Pref) = N_Selected_Component + and then Present (Entity (Selector_Name (Pref))) + and then Entity (Selector_Name (Pref)) = RTE_Record_Component (RE_Prims_Ptr) then null; - -- The discrete_range is specified by a subtype indication. Create a - -- shallow copy and inherit the type, parent and source location from - -- the discrete_range. This ensures that the range check is inserted - -- relative to the slice and that the runtime exception points to the - -- proper construct. + -- The discrete_range is specified by a subtype name. Create an + -- equivalent range attribute, apply checks to this attribute, but + -- insert them into the range expression of the slice itself. elsif Is_Entity_Name (Drange) then - Dexpr := New_Copy (Scalar_Range (Entity (Drange))); + Dexpr := + Make_Attribute_Reference + (Sloc (Drange), + Prefix => + New_Occurrence_Of (Entity (Drange), Sloc (Drange)), + Attribute_Name => Name_Range); + + Analyze_And_Resolve (Dexpr, Etype (Drange)); - Set_Etype (Dexpr, Etype (Drange)); - Set_Parent (Dexpr, Parent (Drange)); - Set_Sloc (Dexpr, Sloc (Drange)); + elsif Nkind (Drange) = N_Subtype_Indication then + Dexpr := Range_Expression (Constraint (Drange)); - -- The discrete_range is a regular range. Resolve the bounds and remove + -- The discrete_range is a regular range (or a range attribute, which + -- will be resolved into a regular range). Resolve the bounds and remove -- their side effects. else @@ -11339,7 +11405,7 @@ package body Sem_Res is end if; if Present (Dexpr) then - Apply_Range_Check (Dexpr, Index_Type); + Apply_Range_Check (Dexpr, Index_Type, Insert_Node => Drange); end if; Set_Slice_Subtype (N); @@ -11367,11 +11433,11 @@ package body Sem_Res is -- Otherwise here is where we check suspicious indexes if Nkind (Drange) = N_Range then - Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); - Warn_On_Suspicious_Index (Name, High_Bound (Drange)); + Warn_On_Suspicious_Index (Pref, Low_Bound (Drange)); + Warn_On_Suspicious_Index (Pref, High_Bound (Drange)); end if; - Resolve_Implicit_Dereference (Prefix (N)); + Resolve_Implicit_Dereference (Pref); Analyze_Dimension (N); Eval_Slice (N); end Resolve_Slice; diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 396f616..8e5b067 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -444,6 +444,12 @@ package body Sem_Type is Find_Dispatching_Type (E)) then Add_One_Interp (N, Interface_Alias (E), T); + + -- Otherwise this is the first interpretation, N has type Any_Type + -- and we must place the new type on the node. + + else + Set_Etype (N, T); end if; return; @@ -1403,7 +1409,9 @@ package body Sem_Type is and then Nkind (Unit_Declaration_Node (S)) = N_Subprogram_Renaming_Declaration - -- Why the Comes_From_Source test here??? + -- Determine if the renaming came from source or was generated as a + -- a result of generic expansion since the actual is represented by + -- a constructed subprogram renaming. and then not Comes_From_Source (Unit_Declaration_Node (S)) @@ -1460,7 +1468,8 @@ package body Sem_Type is then return True; - -- ??? There are possibly other cases to consider + -- Formal_Typ is a private view, or Opnd_Typ and Formal_Typ are + -- compatible only on a base-type basis. else return False; @@ -3415,7 +3424,8 @@ package body Sem_Type is -- Ada 2005 (AI-251): T1 is a concrete type that implements the -- class-wide interface T2 - elsif Is_Class_Wide_Type (T2) + elsif Is_Tagged_Type (T1) + and then Is_Class_Wide_Type (T2) and then Is_Interface (Etype (T2)) and then Interface_Present_In_Ancestor (Typ => T1, Iface => Etype (T2)) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 45a338a..b5f3d4c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -391,8 +391,7 @@ package body Sem_Util is and then (Is_Static_Coextension (N) or else Is_Dynamic_Coextension (N)) then - return Make_Level_Literal - (Scope_Depth (Standard_Standard)); + return Make_Level_Literal (Scope_Depth (Standard_Standard)); end if; -- Named access types have a designated level @@ -416,11 +415,14 @@ package body Sem_Util is if Debug_Flag_Underscore_B then return Make_Level_Literal (Typ_Access_Level (Etype (N))); - -- Otherwise the level is that of the subprogram + -- For function calls the level is that of the innermost + -- master, otherwise (for allocators etc.) we get the level + -- of the corresponding anonymous access type, which is + -- calculated through the normal path of execution. - else + elsif Nkind (N) = N_Function_Call then return Make_Level_Literal - (Subprogram_Access_Level (Entity (Name (N)))); + (Innermost_Master_Scope_Depth (Expr)); end if; end if; @@ -713,15 +715,25 @@ package body Sem_Util is return Make_Level_Literal (Typ_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. + -- Move up the renamed entity or object if it came from source + -- since expansion may have created a dummy renaming under + -- certain circumstances. + + -- Note: We check if the original node of the renaming comes + -- from source because the node may have been rewritten. elsif Present (Renamed_Object (E)) - and then Comes_From_Source (Renamed_Object (E)) + and then Comes_From_Source (Original_Node (Renamed_Object (E))) then return Accessibility_Level (Renamed_Object (E)); + -- Move up renamed entities + + elsif Present (Renamed_Entity (E)) + and then Comes_From_Source (Original_Node (Renamed_Entity (E))) + then + return Accessibility_Level (Renamed_Entity (E)); + -- Named access types get their level from their associated type elsif Is_Named_Access_Type (Etype (E)) then @@ -2212,180 +2224,6 @@ package body Sem_Util is return Empty; end Build_Actual_Subtype_Of_Component; - --------------------------------- - -- Build_Class_Wide_Clone_Body -- - --------------------------------- - - procedure Build_Class_Wide_Clone_Body - (Spec_Id : Entity_Id; - Bod : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Bod); - Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); - Clone_Body : Node_Id; - Assoc_List : constant Elist_Id := New_Elmt_List; - - begin - -- The declaration of the class-wide clone was created when the - -- corresponding class-wide condition was analyzed. - - -- The body of the original condition may contain references to - -- the formals of Spec_Id. In the body of the class-wide clone, - -- these must be replaced with the corresponding formals of - -- the clone. - - declare - Spec_Formal_Id : Entity_Id := First_Formal (Spec_Id); - Clone_Formal_Id : Entity_Id := First_Formal (Clone_Id); - begin - while Present (Spec_Formal_Id) loop - Append_Elmt (Spec_Formal_Id, Assoc_List); - Append_Elmt (Clone_Formal_Id, Assoc_List); - - Next_Formal (Spec_Formal_Id); - Next_Formal (Clone_Formal_Id); - end loop; - end; - - Clone_Body := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Parent (Clone_Id)), - Declarations => Declarations (Bod), - Handled_Statement_Sequence => - New_Copy_Tree (Handled_Statement_Sequence (Bod), - Map => Assoc_List)); - - -- The new operation is internal and overriding indicators do not apply - -- (the original primitive may have carried one). - - Set_Must_Override (Specification (Clone_Body), False); - - -- If the subprogram body is the proper body of a stub, insert the - -- subprogram after the stub, i.e. the same declarative region as - -- the original sugprogram. - - if Nkind (Parent (Bod)) = N_Subunit then - Insert_After (Corresponding_Stub (Parent (Bod)), Clone_Body); - - else - Insert_Before (Bod, Clone_Body); - end if; - - Analyze (Clone_Body); - end Build_Class_Wide_Clone_Body; - - --------------------------------- - -- Build_Class_Wide_Clone_Call -- - --------------------------------- - - function Build_Class_Wide_Clone_Call - (Loc : Source_Ptr; - Decls : List_Id; - Spec_Id : Entity_Id; - Spec : Node_Id) return Node_Id - is - Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); - Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id); - - Actuals : List_Id; - Call : Node_Id; - Formal : Entity_Id; - New_Body : Node_Id; - New_F_Spec : Entity_Id; - New_Formal : Entity_Id; - - begin - Actuals := Empty_List; - Formal := First_Formal (Spec_Id); - New_F_Spec := First (Parameter_Specifications (Spec)); - - -- Build parameter association for call to class-wide clone. - - while Present (Formal) loop - New_Formal := Defining_Identifier (New_F_Spec); - - -- If controlling argument and operation is inherited, add conversion - -- to parent type for the call. - - if Etype (Formal) = Par_Type - and then not Is_Empty_List (Decls) - then - Append_To (Actuals, - Make_Type_Conversion (Loc, - New_Occurrence_Of (Par_Type, Loc), - New_Occurrence_Of (New_Formal, Loc))); - - else - Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); - end if; - - Next_Formal (Formal); - Next (New_F_Spec); - end loop; - - if Ekind (Spec_Id) = E_Procedure then - Call := - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Clone_Id, Loc), - Parameter_Associations => Actuals); - else - Call := - Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Clone_Id, Loc), - Parameter_Associations => Actuals)); - end if; - - New_Body := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Spec), - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call), - End_Label => Make_Identifier (Loc, Chars (Spec_Id)))); - - return New_Body; - end Build_Class_Wide_Clone_Call; - - --------------------------------- - -- Build_Class_Wide_Clone_Decl -- - --------------------------------- - - procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Spec_Id); - Clone_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_External_Name (Chars (Spec_Id), Suffix => "CL")); - - Decl : Node_Id; - Spec : Node_Id; - - begin - Spec := Copy_Subprogram_Spec (Parent (Spec_Id)); - Set_Must_Override (Spec, False); - Set_Must_Not_Override (Spec, False); - Set_Defining_Unit_Name (Spec, Clone_Id); - - Decl := Make_Subprogram_Declaration (Loc, Spec); - Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id))); - - -- Link clone to original subprogram, for use when building body and - -- wrapper call to inherited operation. - - Set_Class_Wide_Clone (Spec_Id, Clone_Id); - - -- Inherit debug info flag from Spec_Id to Clone_Id to allow debugging - -- of the class-wide clone subprogram. - - if Needs_Debug_Info (Spec_Id) then - Set_Debug_Info_Needed (Clone_Id); - end if; - end Build_Class_Wide_Clone_Decl; - ----------------------------- -- Build_Component_Subtype -- ----------------------------- @@ -5012,6 +4850,7 @@ package body Sem_Util is and then not Mentions_Post_State (Expr) and then not (Is_Ghost_Entity (Subp_Id) and then Has_No_Output (Subp_Id)) + and then not Is_Wrapper (Subp_Id) then if Pragma_Name (Prag) = Name_Contract_Cases then Error_Msg_NE (Adjust_Message @@ -5877,6 +5716,30 @@ package body Sem_Util is end if; end Choice_List; + --------------------- + -- Class_Condition -- + --------------------- + + function Class_Condition + (Kind : Condition_Kind; + Subp : Entity_Id) return Node_Id is + + begin + case Kind is + when Class_Postcondition => + return Class_Postconditions (Subp); + + when Class_Precondition => + return Class_Preconditions (Subp); + + when Ignored_Class_Postcondition => + return Ignored_Class_Postconditions (Subp); + + when Ignored_Class_Precondition => + return Ignored_Class_Preconditions (Subp); + end case; + end Class_Condition; + ------------------------- -- Collect_Body_States -- ------------------------- @@ -7072,6 +6935,79 @@ package body Sem_Util is end if; end Corresponding_Generic_Type; + -------------------------------- + -- Corresponding_Primitive_Op -- + -------------------------------- + + function Corresponding_Primitive_Op + (Ancestor_Op : Entity_Id; + Descendant_Type : Entity_Id) return Entity_Id + is + Typ : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op); + Elmt : Elmt_Id; + Subp : Entity_Id; + Prim : Entity_Id; + begin + pragma Assert (Is_Dispatching_Operation (Ancestor_Op)); + pragma Assert (Is_Ancestor (Typ, Descendant_Type) + or else Is_Progenitor (Typ, Descendant_Type)); + + Elmt := First_Elmt (Primitive_Operations (Descendant_Type)); + + while Present (Elmt) loop + Subp := Node (Elmt); + + -- For regular primitives we only need to traverse the chain of + -- ancestors when the name matches the name of Ancestor_Op, but + -- for predefined dispatching operations we cannot rely on the + -- name of the primitive to identify a candidate since their name + -- is internally built adding a suffix to the name of the tagged + -- type. + + if Chars (Subp) = Chars (Ancestor_Op) + or else Is_Predefined_Dispatching_Operation (Subp) + then + -- Handle case where Ancestor_Op is a primitive of a progenitor. + -- We rely on internal entities that map interface primitives: + -- their attribute Interface_Alias references the interface + -- primitive, and their Alias attribute references the primitive + -- of Descendant_Type implementing that interface primitive. + + if Present (Interface_Alias (Subp)) then + if Interface_Alias (Subp) = Ancestor_Op then + return Alias (Subp); + end if; + + -- Traverse the chain of ancestors searching for Ancestor_Op. + -- Overridden primitives have attribute Overridden_Operation; + -- inherited primitives have attribute Alias. + + else + Prim := Subp; + + while Present (Overridden_Operation (Prim)) + or else Present (Alias (Prim)) + loop + if Present (Overridden_Operation (Prim)) then + Prim := Overridden_Operation (Prim); + else + Prim := Alias (Prim); + end if; + + if Prim = Ancestor_Op then + return Subp; + end if; + end loop; + end if; + end if; + + Next_Elmt (Elmt); + end loop; + + pragma Assert (False); + return Empty; + end Corresponding_Primitive_Op; + -------------------- -- Current_Entity -- -------------------- @@ -7444,7 +7380,7 @@ package body Sem_Util is return False; end if; - Next_Index (Indx); + Next (Indx); end loop; end; @@ -8732,6 +8668,10 @@ package body Sem_Util is and then Comes_From_Source (C) and then Comes_From_Source (Def_Id) + -- Don't warn within a generic instantiation + + and then not In_Instance + -- Don't warn unless entity in question is in extended main source and then In_Extended_Main_Source_Unit (Def_Id) @@ -13389,8 +13329,8 @@ package body Sem_Util is -------------------------------------- function Has_Preelaborable_Initialization - (E : Entity_Id; - Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean + (E : Entity_Id; + Preelab_Init_Expr : Node_Id := Empty) return Boolean is Has_PE : Boolean; @@ -13398,6 +13338,12 @@ package body Sem_Util is -- Check component/discriminant chain, sets Has_PE False if a component -- or discriminant does not meet the preelaborable initialization rules. + function Type_Named_In_Preelab_Init_Expression + (Typ : Entity_Id; + Expr : Node_Id) return Boolean; + -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr + -- (where Expr may be a conjunction of one or more P_I attributes). + ---------------------- -- Check_Components -- ---------------------- @@ -13446,7 +13392,7 @@ package body Sem_Util is if No (Exp) then if not Has_Preelaborable_Initialization - (Etype (Ent), Formal_Types_Have_Preelab_Init) + (Etype (Ent), Preelab_Init_Expr) then Has_PE := False; exit; @@ -13464,6 +13410,44 @@ package body Sem_Util is end loop; end Check_Components; + -------------------------------------- + -- Type_Named_In_Preelab_Expression -- + -------------------------------------- + + function Type_Named_In_Preelab_Init_Expression + (Typ : Entity_Id; + Expr : Node_Id) return Boolean + is + begin + -- Return True if Expr is a Preelaborable_Initialization attribute + -- and the prefix is a subtype that has the same type as Typ. + + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Preelaborable_Initialization + and then Is_Entity_Name (Prefix (Expr)) + and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ) + then + return True; + + -- In the case where Expr is a conjunction, test whether either + -- operand is a Preelaborable_Initialization attribute whose prefix + -- has the same type as Typ, and return True if so. + + elsif Nkind (Expr) = N_Op_And + and then + (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr)) + or else + Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr))) + then + return True; + + -- Typ not named in a Preelaborable_Initialization attribute of Expr + + else + return False; + end if; + end Type_Named_In_Preelab_Init_Expression; + -- Start of processing for Has_Preelaborable_Initialization begin @@ -13494,7 +13478,7 @@ package body Sem_Util is elsif Is_Array_Type (E) then Has_PE := Has_Preelaborable_Initialization - (Component_Type (E), Formal_Types_Have_Preelab_Init); + (Component_Type (E), Preelab_Init_Expr); -- A derived type has preelaborable initialization if its parent type -- has preelaborable initialization and (in the case of a derived record @@ -13509,7 +13493,11 @@ package body Sem_Util is -- of a generic formal derived type has preelaborable initialization. -- (See comment on spec of Has_Preelaborable_Initialization.) - if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then + if Is_Generic_Type (E) + and then Present (Preelab_Init_Expr) + and then + Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr) + then return True; end if; @@ -13522,7 +13510,8 @@ package body Sem_Util is -- First check whether ancestor type has preelaborable initialization - Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); + Has_PE := Has_Preelaborable_Initialization + (Etype (Base_Type (E)), Preelab_Init_Expr); -- If OK, check extension components (if any) @@ -13553,7 +13542,11 @@ package body Sem_Util is -- of a generic formal private type has preelaborable initialization. -- (See comment on spec of Has_Preelaborable_Initialization.) - if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then + if Is_Generic_Type (E) + and then Present (Preelab_Init_Expr) + and then + Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr) + then return True; else return False; @@ -16264,12 +16257,14 @@ package body Sem_Util is Names_Match (Assign_Indexed_1, Assign_Indexed_2); end; + -- Checking for this aspect is performed elsewhere during freezing + when Aspect_No_Controlled_Parts => + return True; + -- 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. + when Aspect_Max_Entry_Queue_Length => + -- This should be unreachable. Max_Entry_Queue_Length is + -- supported only for protected entries, not for types. pragma Assert (Serious_Errors_Detected /= 0); return True; @@ -16924,6 +16919,15 @@ package body Sem_Util is end if; if Is_Entity_Name (P) then + -- The Etype may not be set on P (which is wrong) in certain + -- corner cases involving the deprecated front-end inlining of + -- subprograms (via -gnatN), so use the Etype set on the + -- the entity for these instances since we know it is present. + + if No (Prefix_Type) then + Prefix_Type := Etype (Entity (P)); + end if; + if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then Prefix_Type := Base_Type (Prefix_Type); end if; @@ -18167,6 +18171,19 @@ package body Sem_Util is if Is_Formal (E) then return False; + + -- If we somehow got an empty value for Scope, the tree must be + -- malformed. Rather than blow up we return True in this case. + + elsif No (Scope (E)) then + return True; + + -- Handle loops since Enclosing_Dynamic_Scope skips them; required to + -- properly handle entities local to quantified expressions in library + -- level specifications. + + elsif Ekind (Scope (E)) = E_Loop then + return False; end if; -- Normal test is simply that the enclosing dynamic scope is Standard @@ -21188,6 +21205,9 @@ package body Sem_Util is -- Is_Variable -- ----------------- + -- Should Is_Variable be refactored to better handle dereferences and + -- technical debt ??? + function Is_Variable (N : Node_Id; Use_Original_Node : Boolean := True) return Boolean @@ -21356,6 +21376,10 @@ package body Sem_Util is and then Nkind (Parent (E)) /= N_Exception_Handler) or else (K = E_Component and then not In_Protected_Function (E)) + or else (Present (Etype (E)) + and then Is_Access_Object_Type (Etype (E)) + and then Is_Access_Variable (Etype (E)) + and then Is_Dereferenced (N)) or else K = E_Out_Parameter or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter @@ -22713,6 +22737,61 @@ package body Sem_Util is return Result; end Might_Raise; + ---------------------------------------- + -- Nearest_Class_Condition_Subprogram -- + ---------------------------------------- + + function Nearest_Class_Condition_Subprogram + (Kind : Condition_Kind; + Spec_Id : Entity_Id) return Entity_Id + is + Subp_Id : constant Entity_Id := Ultimate_Alias (Spec_Id); + + begin + -- Prevent cascaded errors + + if not Is_Dispatching_Operation (Subp_Id) then + return Empty; + + -- No need to search if this subprogram has class-wide postconditions + + elsif Present (Class_Condition (Kind, Subp_Id)) then + return Subp_Id; + end if; + + -- Process the contracts of inherited subprograms, looking for + -- class-wide pre/postconditions. + + declare + Subps : constant Subprogram_List := Inherited_Subprograms (Subp_Id); + Subp_Id : Entity_Id; + + begin + for Index in Subps'Range loop + Subp_Id := Subps (Index); + + if Present (Alias (Subp_Id)) then + Subp_Id := Ultimate_Alias (Subp_Id); + end if; + + -- Wrappers of class-wide pre/postconditions reference the + -- parent primitive that has the inherited contract. + + if Is_Wrapper (Subp_Id) + and then Present (LSP_Subprogram (Subp_Id)) + then + Subp_Id := LSP_Subprogram (Subp_Id); + end if; + + if Present (Class_Condition (Kind, Subp_Id)) then + return Subp_Id; + end if; + end loop; + end; + + return Empty; + end Nearest_Class_Condition_Subprogram; + -------------------------------- -- Nearest_Enclosing_Instance -- -------------------------------- @@ -24707,7 +24786,7 @@ package body Sem_Util is -- Visit_Node -- ---------------- - procedure Visit_Node (N : Node_Or_Entity_Id) is + procedure Visit_Node (N : Node_Id) is begin pragma Assert (Nkind (N) not in N_Entity); @@ -29279,7 +29358,7 @@ package body Sem_Util is (Designated_Type (Btyp), Allow_Alt_Model); end if; - -- When an anonymous access type's Assoc_Ent is specifiedi, + -- When an anonymous access type's Assoc_Ent is specified, -- calculate the result based on the general accessibility -- level routine. @@ -29301,10 +29380,22 @@ package body Sem_Util is (Associated_Node_For_Itype (Typ)); if Present (Def_Ent) then - -- When the type comes from an anonymous access parameter, - -- the level is that of the subprogram declaration. + -- When the defining entity is a subprogram then we know the + -- anonymous access type Typ has been generated to either + -- describe an anonymous access type formal or an anonymous + -- access result type. + + -- Since we are only interested in the formal case, avoid + -- the anonymous access result type. + + if Ekind (Def_Ent) in Subprogram_Kind + and then not (Ekind (Def_Ent) = E_Function + and then Etype (Def_Ent) = Typ) + then + -- When the type comes from an anonymous access + -- parameter, the level is that of the subprogram + -- declaration. - if Ekind (Def_Ent) in Subprogram_Kind then return Scope_Depth (Def_Ent); -- When the type is an access discriminant, the level is @@ -31459,8 +31550,16 @@ package body Sem_Util is -- type case correctly, so we avoid that problem by -- returning True here. return True; + elsif Ada_Version < Ada_2022 then return False; + + elsif Inside_Class_Condition_Preanalysis then + -- No need to evaluate it during preanalysis of a class-wide + -- pre/postcondition since the expression is not installed yet + -- on its definite context. + return False; + elsif not Is_Conditionally_Evaluated (Expr) then return False; else @@ -31517,7 +31616,12 @@ package body Sem_Util is -- quantified_expression. if Nkind (Par) = N_Quantified_Expression - and then Trailer = Condition (Par) + and then Trailer = Condition (Par) + then + return True; + elsif Nkind (Par) = N_Expression_With_Actions + and then + Nkind (Original_Node (Par)) = N_Quantified_Expression then return True; end if; @@ -32043,11 +32147,172 @@ package body Sem_Util is end if; end; end if; + return False; end Is_Access_Type_For_Indirect_Temp; end Indirect_Temps; end Old_Attr_Util; + + package body Storage_Model_Support is + + ----------------------------------- + -- Get_Storage_Model_Type_Entity -- + ----------------------------------- + + function Get_Storage_Model_Type_Entity + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + pragma Assert + (Is_Type (Typ) + and then + Nam in Name_Address_Type + | Name_Null_Address + | Name_Allocate + | Name_Deallocate + | Name_Copy_From + | Name_Copy_To + | Name_Storage_Size); + + SMT_Aspect_Value : constant Node_Id := + Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type); + Assoc : Node_Id; + + begin + if No (SMT_Aspect_Value) then + return Empty; + + else + Assoc := First (Component_Associations (SMT_Aspect_Value)); + while Present (Assoc) loop + if Chars (First (Choices (Assoc))) = Nam then + return Entity (Expression (Assoc)); + end if; + + Next (Assoc); + end loop; + + return Empty; + end if; + end Get_Storage_Model_Type_Entity; + + ----------------------------------------- + -- Has_Designated_Storage_Model_Aspect -- + ----------------------------------------- + + function Has_Designated_Storage_Model_Aspect + (Typ : Entity_Id) return Boolean + is + begin + return Present (Find_Aspect (Typ, Aspect_Designated_Storage_Model)); + end Has_Designated_Storage_Model_Aspect; + + ----------------------------------- + -- Has_Storage_Model_Type_Aspect -- + ----------------------------------- + + function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean + is + begin + return Present (Find_Aspect (Typ, Aspect_Storage_Model_Type)); + end Has_Storage_Model_Type_Aspect; + + -------------------------- + -- Storage_Model_Object -- + -------------------------- + + function Storage_Model_Object (Typ : Entity_Id) return Entity_Id is + begin + if Has_Designated_Storage_Model_Aspect (Typ) then + return + Entity + (Find_Value_Of_Aspect (Typ, Aspect_Designated_Storage_Model)); + else + return Empty; + end if; + end Storage_Model_Object; + + ------------------------ + -- Storage_Model_Type -- + ------------------------ + + function Storage_Model_Type (Obj : Entity_Id) return Entity_Id is + begin + if Present + (Find_Value_Of_Aspect (Etype (Obj), Aspect_Storage_Model_Type)) + then + return Etype (Obj); + else + return Empty; + end if; + end Storage_Model_Type; + + -------------------------------- + -- Storage_Model_Address_Type -- + -------------------------------- + + function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Address_Type); + end Storage_Model_Address_Type; + + -------------------------------- + -- Storage_Model_Null_Address -- + -------------------------------- + + function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Null_Address); + end Storage_Model_Null_Address; + + ---------------------------- + -- Storage_Model_Allocate -- + ---------------------------- + + function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Allocate); + end Storage_Model_Allocate; + + ------------------------------ + -- Storage_Model_Deallocate -- + ------------------------------ + + function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Deallocate); + end Storage_Model_Deallocate; + + ----------------------------- + -- Storage_Model_Copy_From -- + ----------------------------- + + function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Copy_From); + end Storage_Model_Copy_From; + + --------------------------- + -- Storage_Model_Copy_To -- + --------------------------- + + function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Copy_To); + end Storage_Model_Copy_To; + + -------------------------------- + -- Storage_Model_Storage_Size -- + -------------------------------- + + function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Storage_Size); + end Storage_Model_Storage_Size; + + end Storage_Model_Support; + 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 7c89585..85010b5 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -283,30 +283,6 @@ package Sem_Util is -- take care of constructing declaration and body of the clone, and -- building the calls to it within the appropriate wrappers. - procedure Build_Class_Wide_Clone_Body - (Spec_Id : Entity_Id; - Bod : Node_Id); - -- Build body of subprogram that has a class-wide condition that contains - -- calls to other primitives. Spec_Id is the Id of the subprogram, and B - -- is its source body, which becomes the body of the clone. - - function Build_Class_Wide_Clone_Call - (Loc : Source_Ptr; - Decls : List_Id; - Spec_Id : Entity_Id; - Spec : Node_Id) return Node_Id; - -- Build a call to the common class-wide clone of a subprogram with - -- class-wide conditions. The body of the subprogram becomes a wrapper - -- for a call to the clone. The inherited operation becomes a similar - -- wrapper to which modified conditions apply, and the call to the - -- clone includes the proper conversion in a call the parent operation. - - procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id); - -- For a subprogram that has a class-wide condition that contains calls - -- to other primitives, build an internal subprogram that is invoked - -- through a type-specific wrapper for all inherited subprograms that - -- may have a modified condition. - procedure Build_Constrained_Itype (N : Node_Id; Typ : Entity_Id; @@ -356,7 +332,7 @@ package Sem_Util is -- carries the name of the reference discriminant. function Build_Overriding_Spec - (Op : Node_Id; + (Op : Entity_Id; Typ : Entity_Id) return Node_Id; -- Build a subprogram specification for the wrapper of an inherited -- operation with a modified pre- or postcondition (See AI12-0113). @@ -527,6 +503,18 @@ package Sem_Util is -- reasons these nodes have a different structure even though they play -- similar roles in array aggregates. + type Condition_Kind is + (Ignored_Class_Precondition, + Ignored_Class_Postcondition, + Class_Precondition, + Class_Postcondition); + -- Kind of class-wide conditions + + function Class_Condition + (Kind : Condition_Kind; + Subp : Entity_Id) return Node_Id; + -- Class-wide Kind condition of Subp + function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id; -- Gather the entities of all abstract states and objects declared in the -- body state space of package body Body_Id. @@ -638,6 +626,13 @@ package Sem_Util is -- attribute, except in the case of formal private and derived types. -- Possible optimization??? + function Corresponding_Primitive_Op + (Ancestor_Op : Entity_Id; + Descendant_Type : Entity_Id) return Entity_Id; + -- Given a primitive subprogram of a tagged type and a (distinct) + -- descendant type of that type, find the corresponding primitive + -- subprogram of the descendant type. + function Current_Entity (N : Node_Id) return Entity_Id; pragma Inline (Current_Entity); -- Find the currently visible definition for a given identifier, that is to @@ -1531,17 +1526,15 @@ package Sem_Util is -- initialization. function Has_Preelaborable_Initialization - (E : Entity_Id; - Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean; + (E : Entity_Id; + Preelab_Init_Expr : Node_Id := Empty) return Boolean; -- Return True iff type E has preelaborable initialization as defined in -- Ada 2005 (see AI-161 for details of the definition of this attribute). - -- If Formal_Types_Have_Preelab_Init is True, indicates that the function - -- should presume that for any subcomponents of formal private or derived - -- types, the types have preelaborable initialization (RM 10.2.1(11.8/5)). - -- NOTE: The treatment of subcomponents of formal types should only apply - -- for types actually specified in the P_I aspect of the outer type, but - -- for now we take a more liberal interpretation. This needs addressing, - -- perhaps by passing the outermost type instead of the simple flag. ??? + -- If Preelab_Init_Expr is present, indicates that the function should + -- presume that for any subcomponent of E that is of a formal private or + -- derived type that is referenced by a Preelaborable_Initialization + -- attribute within the expression Preelab_Init_Expr, the formal type has + -- preelaborable initialization (RM 10.2.1(11.8/5) and AI12-0409). function Has_Prefix (N : Node_Id) return Boolean; -- Return True if N has attribute Prefix @@ -2614,6 +2607,12 @@ package Sem_Util is -- if we're not sure, we return True. If N is a subprogram body, this is -- about whether execution of that body can raise. + function Nearest_Class_Condition_Subprogram + (Kind : Condition_Kind; + Spec_Id : Entity_Id) return Entity_Id; + -- Return the nearest ancestor containing the merged class-wide conditions + -- that statically apply to Spec_Id; return Empty otherwise. + function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id; -- Return the entity of the nearest enclosing instance which encapsulates -- entity E. If no such instance exits, return Empty. @@ -3551,4 +3550,76 @@ package Sem_Util is end Indirect_Temps; end Old_Attr_Util; + + package Storage_Model_Support is + + -- This package provides a set of utility functions related to support + -- for the Storage_Model feature. These functions provide an interface + -- that the compiler (in particular back-end phases such as gigi and + -- GNAT-LLVM) can use to easily obtain entities and operations that + -- are specified for types in the aspects Storage_Model_Type and + -- Designated_Storage_Model. + + function Get_Storage_Model_Type_Entity + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Given type Typ with aspect Storage_Model_Type, returns the Entity_Id + -- corresponding to the entity associated with Nam in the aspect. If the + -- type does not specify the aspect, or such an entity is not present, + -- then returns Empty. (Note: This function is modeled on function + -- Get_Iterable_Type_Primitive.) + + function Has_Designated_Storage_Model_Aspect + (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ specifies aspect Designated_Storage_Model + + function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ specifies aspect Storage_Model_Type + + function Storage_Model_Object (Typ : Entity_Id) return Entity_Id; + -- Given an access type with aspect Designated_Storage_Model, returns + -- the storage-model object associated with that type; returns Empty + -- if there is no associated object. + + function Storage_Model_Type (Obj : Entity_Id) return Entity_Id; + -- Given an object Obj of a type specifying aspect Storage_Model_Type, + -- returns that type; otherwise returns Empty. + + function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- the type specified for the Address_Type choice in that aspect; + -- returns Empty if the aspect or the type isn't specified. + + function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- constant specified for Null_Address choice in that aspect; returns + -- Empty if the aspect or the constant object isn't specified. + + function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Allocate choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Deallocate choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Copy_From choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Copy_To choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- function specified for Storage_Size choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + end Storage_Model_Support; + end Sem_Util; diff --git a/gcc/ada/sinfo-utils.adb b/gcc/ada/sinfo-utils.adb index 083c12e..cf0ecc1 100644 --- a/gcc/ada/sinfo-utils.adb +++ b/gcc/ada/sinfo-utils.adb @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Atree; +with Atree; use Atree; with Debug; use Debug; with Output; use Output; with Seinfo; @@ -55,7 +55,7 @@ package body Sinfo.Utils is -- The second method is much faster if the amount of Ada code being -- compiled is large. - ww : Node_Id'Base := Node_Id'First - 1; + ww : Node_Id'Base := Node_Low_Bound - 1; pragma Export (Ada, ww); Watch_Node : Node_Id'Base renames ww; -- Node to "watch"; that is, whenever a node is created, we check if it @@ -72,8 +72,8 @@ package body Sinfo.Utils is procedure nnd (N : Node_Id); pragma Export (Ada, nnd); - -- For debugging. If debugging is turned on, New_Node and New_Entity call - -- this. If debug flag N is turned on, this prints out the new node. + -- For debugging. If debugging is turned on, New_Node and New_Entity (etc.) + -- call this. If debug flag N is turned on, this prints out the new node. -- -- If Node = Watch_Node, this prints out the new node and calls -- New_Node_Breakpoint. Otherwise, does nothing. @@ -265,7 +265,7 @@ package body Sinfo.Utils is if Fields (J) /= F_Link then -- Don't walk Parent! declare Desc : Field_Descriptor renames - Node_Field_Descriptors (Fields (J)); + Field_Descriptors (Fields (J)); begin if Is_In_Union_Id (Desc.Kind) then Action (Get_Node_Field_Union (N, Desc.Offset)); @@ -290,7 +290,7 @@ package body Sinfo.Utils is if Fields (J) /= F_Link then -- Don't walk Parent! declare Desc : Field_Descriptor renames - Node_Field_Descriptors (Fields (J)); + Field_Descriptors (Fields (J)); begin if Is_In_Union_Id (Desc.Kind) then Set_Node_Field_Union diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads index 2023e67..e3bb8d4 100644 --- a/gcc/ada/sinfo-utils.ads +++ b/gcc/ada/sinfo-utils.ads @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Nodes; use Sinfo.Nodes; package Sinfo.Utils is diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 20a6125..b99edf7 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -411,10 +411,6 @@ package Sinfo is -- Assignment_OK set if modification is OK -- Is_Controlling_Actual set for controlling argument - -- Note: the utility program that creates the Treeprs spec (in the file - -- xtreeprs.adb) knows about the special fields here, so it must be - -- modified if any change is made to these fields. - -- Note: see under (EXPRESSION) for further details on the use of -- the Paren_Count field to record the number of parentheses levels. diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 34f1cef..e1af28b 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -149,6 +149,7 @@ package Snames is Name_Default_Value : constant Name_Id := N + $; Name_Default_Component_Value : constant Name_Id := N + $; + Name_Designated_Storage_Model : constant Name_Id := N + $; Name_Dimension : constant Name_Id := N + $; Name_Dimension_System : constant Name_Id := N + $; Name_Disable_Controlled : constant Name_Id := N + $; @@ -162,6 +163,8 @@ package Snames is Name_Relaxed_Initialization : constant Name_Id := N + $; Name_Stable_Properties : constant Name_Id := N + $; Name_Static_Predicate : constant Name_Id := N + $; + Name_Storage_Model : constant Name_Id := N + $; + Name_Storage_Model_Type : constant Name_Id := N + $; Name_String_Literal : constant Name_Id := N + $; Name_Synchronization : constant Name_Id := N + $; Name_Unimplemented : constant Name_Id := N + $; @@ -526,6 +529,7 @@ package Snames is Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT + Name_CUDA_Device : constant Name_Id := N + $; -- GNAT Name_CUDA_Execute : constant Name_Id := N + $; -- GNAT Name_CUDA_Global : constant Name_Id := N + $; -- GNAT @@ -778,6 +782,7 @@ package Snames is -- Other special names used in processing attributes, aspects, and pragmas + Name_Address_Type : constant Name_Id := N + $; Name_Aggregate : constant Name_Id := N + $; Name_Allow : constant Name_Id := N + $; Name_Amount : constant Name_Id := N + $; @@ -797,6 +802,8 @@ package Snames is Name_Component : constant Name_Id := N + $; Name_Component_Size_4 : constant Name_Id := N + $; Name_Copy : constant Name_Id := N + $; + Name_Copy_From : constant Name_Id := N + $; + Name_Copy_To : constant Name_Id := N + $; Name_D_Float : constant Name_Id := N + $; Name_Decreases : constant Name_Id := N + $; Name_Disable : constant Name_Id := N + $; @@ -866,6 +873,7 @@ package Snames is Name_Nominal : constant Name_Id := N + $; Name_Non_Volatile : constant Name_Id := N + $; Name_None : constant Name_Id := N + $; + Name_Null_Address : constant Name_Id := N + $; Name_On : constant Name_Id := N + $; Name_Optional : constant Name_Id := N + $; Name_Policy : constant Name_Id := N + $; @@ -963,8 +971,8 @@ package Snames is Name_Elaborated : constant Name_Id := N + $; -- GNAT Name_Emax : constant Name_Id := N + $; -- Ada 83 Name_Enabled : constant Name_Id := N + $; -- GNAT - Name_Enum_Rep : constant Name_Id := N + $; -- GNAT - Name_Enum_Val : constant Name_Id := N + $; -- GNAT + Name_Enum_Rep : constant Name_Id := N + $; -- Ada 22 + Name_Enum_Val : constant Name_Id := N + $; -- Ada 22 Name_Epsilon : constant Name_Id := N + $; -- Ada 83 Name_Exponent : constant Name_Id := N + $; Name_External_Tag : constant Name_Id := N + $; @@ -1017,7 +1025,7 @@ package Snames is Name_Modulus : constant Name_Id := N + $; Name_Null_Parameter : constant Name_Id := N + $; -- GNAT Name_Object_Size : constant Name_Id := N + $; -- GNAT - Name_Old : constant Name_Id := N + $; -- GNAT + Name_Old : constant Name_Id := N + $; -- Ada 12 Name_Overlaps_Storage : constant Name_Id := N + $; -- GNAT Name_Partition_ID : constant Name_Id := N + $; Name_Passed_By_Reference : constant Name_Id := N + $; -- GNAT @@ -1028,7 +1036,7 @@ package Snames is Name_Priority : constant Name_Id := N + $; -- Ada 05 Name_Range : constant Name_Id := N + $; Name_Range_Length : constant Name_Id := N + $; -- GNAT - Name_Reduce : constant Name_Id := N + $; -- GNAT + Name_Reduce : constant Name_Id := N + $; -- Ada 22 Name_Ref : constant Name_Id := N + $; -- GNAT Name_Restriction_Set : constant Name_Id := N + $; -- GNAT Name_Result : constant Name_Id := N + $; -- GNAT @@ -1392,7 +1400,6 @@ package Snames is -- Note that the UP_ prefix means use the rest of the name in uppercase, -- e.g. Name_UP_RESULT corresponds to the name "RESULT". - Name_Unaligned_Valid : constant Name_Id := N + $; Name_UP_RESULT : constant Name_Id := N + $; Name_Suspension_Object : constant Name_Id := N + $; Name_Synchronous_Task_Control : constant Name_Id := N + $; @@ -1862,6 +1869,7 @@ package Snames is Pragma_CPP_Constructor, Pragma_CPP_Virtual, Pragma_CPP_Vtable, + Pragma_CUDA_Device, Pragma_CUDA_Execute, Pragma_CUDA_Global, Pragma_Deadline_Floor, diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c index 82e0c5a..5074c8e 100644 --- a/gcc/ada/socket.c +++ b/gcc/ada/socket.c @@ -314,6 +314,7 @@ __gnat_gethostbyaddr (const char *addr, int len, int type, ret->h_addrtype = AF_INET; ret->h_length = 4; ret->h_addr_list = &vxw_h_addr_list; + return 0; } int @@ -587,6 +588,9 @@ __gnat_inet_pton (int af, const char *src, void *dst) { *(in_addr_t *)dst = addr; } return rc; + +#else + return -1; #endif } #endif diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 8dc96a4..9b78ada 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2075,7 +2075,7 @@ package body Sprint is Sprint_Node (Name (Node)); Write_Char (';'); - when N_Generic_Package_Declaration => + when N_Generic_Declaration => Extra_Blank_Line; Write_Indent_Str_Sloc ("generic "); Sprint_Indented_List (Generic_Formal_Declarations (Node)); @@ -2097,14 +2097,6 @@ package body Sprint is Sprint_Node (Name (Node)); Write_Char (';'); - when N_Generic_Subprogram_Declaration => - Extra_Blank_Line; - Write_Indent_Str_Sloc ("generic "); - Sprint_Indented_List (Generic_Formal_Declarations (Node)); - Write_Indent; - Sprint_Node (Specification (Node)); - Write_Char (';'); - when N_Goto_Statement => Write_Indent_Str_Sloc ("goto "); Sprint_Node (Name (Node)); diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index ee951e3..2c50b36 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -907,6 +907,10 @@ __gnat_is_file_not_found_error (int errno_val) if (errno_val == ENOENT) return 1; #ifdef __vxworks + /* Starting with VxWorks 21.03, the fopen() function can set errno to + * ENODEV when the prefix of the path does not match any known device. */ + else if (errno_val == ENODEV) + return 1; /* In the case of VxWorks, we also have to take into account various * filesystem-specific variants of this error. */ diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 48f76cb..4c7833b 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -130,9 +130,7 @@ package body Treepr is procedure Capitalize (S : in out String); -- Turns an identifier into Mixed_Case - function Image (F : Node_Field) return String; - - function Image (F : Entity_Field) return String; + function Image (F : Node_Or_Entity_Field) return String; procedure Print_Init; -- Initialize for printing of tree with descendants @@ -281,7 +279,7 @@ package body Treepr is -- Image -- ----------- - function Image (F : Node_Field) return String is + function Image (F : Node_Or_Entity_Field) return String is begin case F is when F_Alloc_For_BIP_Return => @@ -321,18 +319,6 @@ package body Treepr is when F_TSS_Elist => return "TSS_Elist"; - when others => - declare - Result : constant String := Capitalize (F'Img); - begin - return Result (3 .. Result'Last); -- Remove "F_" - end; - end case; - end Image; - - function Image (F : Entity_Field) return String is - begin - case F is when F_BIP_Initialization_Call => return "BIP_Initialization_Call"; when F_Body_Needed_For_SAL => @@ -666,7 +652,7 @@ package body Treepr is for Field_Index in Fields'Range loop declare FD : Field_Descriptor renames - Entity_Field_Descriptors (Fields (Field_Index)); + Field_Descriptors (Fields (Field_Index)); begin if Should_Print (Fields (Field_Index)) and then (FD.Kind = Flag_Field) = Print_Flags @@ -1266,14 +1252,21 @@ package body Treepr is -- Print Chars field if present - if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then - Print_Str (Prefix); - Print_Str ("Chars = "); - Print_Name (Chars (N)); - Write_Str (" (Name_Id="); - Write_Int (Int (Chars (N))); - Write_Char (')'); - Print_Eol; + if Nkind (N) in N_Has_Chars then + if Field_Is_Initial_Zero (N, F_Chars) then + Print_Str (Prefix); + Print_Str ("Chars = initial zero"); + Print_Eol; + + elsif Chars (N) /= No_Name then + Print_Str (Prefix); + Print_Str ("Chars = "); + Print_Name (Chars (N)); + Write_Str (" (Name_Id="); + Write_Int (Int (Chars (N))); + Write_Char (')'); + Print_Eol; + end if; end if; -- Special field print operations for non-entity nodes @@ -1454,7 +1447,7 @@ package body Treepr is for Field_Index in Fields'Range loop declare FD : Field_Descriptor renames - Node_Field_Descriptors (Fields (Field_Index)); + Field_Descriptors (Fields (Field_Index)); begin if Should_Print (Fields (Field_Index)) and then (FD.Kind = Flag_Field) = Print_Flags @@ -1624,7 +1617,14 @@ package body Treepr is if Nkind (N) in N_Has_Chars then Write_Char (' '); - Print_Name (Chars (N)); + + if Field_Is_Initial_Zero (N, F_Chars) then + Print_Str ("Chars = initial zero"); + Print_Eol; + + else + Print_Name (Chars (N)); + end if; end if; if Nkind (N) in N_Entity then @@ -2265,7 +2265,7 @@ package body Treepr is for Field_Index in A'Range loop declare F : constant Node_Field := A (Field_Index); - FD : Field_Descriptor renames Node_Field_Descriptors (F); + FD : Field_Descriptor renames Field_Descriptors (F); begin if FD.Kind in Node_Id_Field | List_Id_Field | Elist_Id_Field -- For all other kinds of descendants (strings, names, uints @@ -2293,7 +2293,7 @@ package body Treepr is for Field_Index in A'Range loop declare F : constant Entity_Field := A (Field_Index); - FD : Field_Descriptor renames Entity_Field_Descriptors (F); + FD : Field_Descriptor renames Field_Descriptors (F); begin if FD.Kind in Node_Id_Field | List_Id_Field | Elist_Id_Field then diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 2caaf50..673f7c6 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -61,6 +61,13 @@ package Types is subtype Nonzero_Int is Int with Predicate => Nonzero_Int /= 0; + type Int_64 is range -2 ** 63 .. +2 ** 63 - 1; + -- Signed 64-bit integer + + subtype Nat_64 is Int_64 range 0 .. Int_64'Last; + subtype Pos_64 is Int_64 range 1 .. Int_64'Last; + subtype Nonzero_Int_64 is Int_64 with Predicate => Nonzero_Int_64 /= 0; + type Word is mod 2 ** 32; -- Unsigned 32-bit integer @@ -991,6 +998,8 @@ package Types is -- Offset of a node field, in units of the size of the field, which is -- always a power of 2. + subtype Node_Offset is Field_Offset'Base range 1 .. Field_Offset'Base'Last; + subtype Slot_Count is Field_Offset; -- Count of number of slots. Same type as Field_Offset to avoid -- proliferation of type conversions. |