diff options
author | Ian Lance Taylor <ian@gcc.gnu.org> | 2019-07-23 18:28:05 +0000 |
---|---|---|
committer | Ian Lance Taylor <ian@gcc.gnu.org> | 2019-07-23 18:28:05 +0000 |
commit | 7731e84e7ec203bea2bf07a273354b78ff853ba0 (patch) | |
tree | 0ca33f701cbac984f561bacd9fef3701d8c76eda /gcc/ada | |
parent | 0baa9d1d59bf17177e80838ebe66df10a7a909c0 (diff) | |
parent | 40768ee0bc9965d109692f884f8588626e01e3fe (diff) | |
download | gcc-7731e84e7ec203bea2bf07a273354b78ff853ba0.zip gcc-7731e84e7ec203bea2bf07a273354b78ff853ba0.tar.gz gcc-7731e84e7ec203bea2bf07a273354b78ff853ba0.tar.bz2 |
Merge from trunk revision 273743.
From-SVN: r273744
Diffstat (limited to 'gcc/ada')
236 files changed, 23727 insertions, 9445 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c28a942..64ac98b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,2174 @@ +2019-07-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations, + Freeze_Entity_Checks): Include Aspect_CPU with other aspects + whose expresssion may depend on a discriminant, and thus require + that components of the type be made visible. + +2019-07-23 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Convert_And_Check_Range): Add Suppress parameter + and pass it in the call to Insert_Actions. Rename local + variable. + (Generate_Range_Check): Minor comment fixes. Pass Range_Check + in the first call to Convert_And_Check_Range and All_Checks in + the second call. + * exp_ch4.adb (Expand_N_Type_Conversion): Reset the + Do_Overflow_Check flag in the float-to-float case too if there + is also a range check. + +2019-07-23 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Activate_Overflow_Check): Remove redundant + argument. + * exp_ch4.adb (Discrete_Range_Check): Reset the overflow flag. + (Expand_N_Type_Conversion): Do not reset it here. + +2019-07-23 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.adb (List_Component_Layout): Pass Decimal to UI_Write. + (Write_Val): Likewise. + +2019-07-23 Ed Schonberg <schonberg@adacore.com> + + * aspects.ads: New table Operational_Aspect, used to distinguish + between aspects that are view-specific, such as those related to + iterators, and representation aspects that apply to all views of + a type. + * aspects.adb (Find_Aspect): If the aspect being sought is + operational, do not ecamine the full view of a private type to + retrieve it. + * sem_ch5.adb (Analyze_Iterator_Specification): Improve error + message when the intended domain of iteration does not implement + the required iterator aspects. + +2019-07-23 Yannick Moy <moy@adacore.com> + + * sem_spark.ads (Is_Local_Context): New function. + * sem_spark.adb (Check_Declaration): Issue errors on violations + of SPARK RM 3.10(4) + (Process_Path): Do not issue error on borrow/observe during + elaboration, as these are caught by the new rule. + +2019-07-23 Yannick Moy <moy@adacore.com> + + * exp_ch7.adb (Create_Finalizer): Force finalizer not to be + Ghost enabled. + * exp_dbug.adb (Get_External_Name): Explain special case of + Ghost finalizer. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.adb (List_Entities): Also list compiled-generated + types present as Etype of objects. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sinfo.ads: Update the documentation about the + Do_Division_Check, Do_Overflow_Check and Do_Range_Check flags. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): Beef up comment. + (Fixup_Universal_Fixed_Operation): Set the base type instead of + the type of the enclosing type conversion on the operation. + +2019-07-22 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_N_In): Do not suggest the use of attribute + 'Valid as a replacement for a range check on a discrete type + when the bounds of the range are given by type conversions, + because in such a case there are distinct types involved and the + subbested attribute replacement would be misplaced. + +2019-07-22 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Get_Root_Object, Is_Path_Expression, + Is_Subpath_Expression): Add parameter Is_Traversal to adapt + these functions to the case of paths returned from a traversal + function. + (Read_Indexes): Handle the case of an if-expression or + case-expression. + (Check_Statement): Check Emit_Messages only when issuing an + error message. This is important as Emit_Messages may store the + information that an error was detected. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Apply_Type_Conversion_Checks): Do not set + Do_Range_Check flag on conversions from fixed-point types + either. + * exp_attr.adb: Add use and with clause for Expander. + (Expand_N_Attribute_Reference) <Fixed_Value, Integer_Value>: Set + the Conversion_OK flag and do not generate overflow/range checks + manually. + * exp_ch4.adb (Expand_N_Qualified_Expression): Remove + superfluous clearing of Do_Range_Check flag. + (Discrete_Range_Check): New procedure to generate a range check + for discrete types. + (Real_Range_Check): Remove redundant local variable and adjust. + Remove useless shortcut. Clear Do_Range_Check flag on all + paths. + (Expand_N_Type_Conversion): Remove redundant test on + Conversion_OK. Call Discrete_Range_Check to generate range + checks on discrete types. Remove obsolete code for + float-to-integer conversions. Add code to generate range checks + for conversions involving fixed-point types. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sprint.ads: Fix pasto in comment. + +2019-07-22 Javier Miranda <miranda@adacore.com> + + * sem_res.adb (Resolve_Actuals): Replace code that displaces the + pointer to an allocated object to reference its secondary + dispatch table by a type conversion (which takes care of + handling all cases). + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sprint.adb (Sprint_Node_Actual) + <N_Decimal_Fixed_Point_Definition>: Swap a couple of spaces. + (Write_Itype): Minor consistency fixes throughout. Add support + for printing ordinary and decimal fixed-point types and + subtypes. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_attr.adb (Expand_Loop_Entry_Attribute): Beef up comment. + +2019-07-22 Ed Schonberg <schonberg@adacore.com> + + * libgnat/s-valboo.ads, libgnat/s-valcha.ads, + libgnat/s-valdec.ads, libgnat/s-valenu.ads, + libgnat/s-valint.ads, libgnat/s-vallld.ads, + libgnat/s-vallli.ads, libgnat/s-valllu.ads, + libgnat/s-valrea.ads, libgnat/s-valuns.ads, + libgnat/s-valwch.ads: Change categorization of packages that + implement attribute 'Value from Pure to Preelaborate, to prevent + undesirable optimizations when the evaluation of the attribute + raises Constraint_Error, but subsequent use of the result of + this evsaluation is removed by a subsequent optimization. + +2019-07-22 Ed Schonberg <schonberg@adacore.com> + + * sem_warn.adb (Check_References): Do not emit s warning on a + referenced entity with no explicit assignment if the type of the + entity has Preelaborable_Initialixation, such as + Exception_Occurrence. + +2019-07-22 Javier Miranda <miranda@adacore.com> + + * exp_ch4.adb (Size_In_Storage_Elements): Improve the expansion + to handle array indexes that are modular type. + (Expand_N_Allocator): For 32-bit targets improve the generation + of the runtime check associated with large arrays supporting + arrays initialized with a qualified expression. + * libgnat/s-imenne.adb (Image_Enumeration_8, + Image_Enumeration_16, Image_Enumeration_32): Define the index of + Index_Table with range Natural'First .. Names'Length since in + the worst case all the literals of the enumeration type would be + single letter literals and the Table built by the frontend would + have as many components as the length of the names string. As a + result of this enhancement, the internal tables declared using + Index_Table have a length closer to the real needs, thus + avoiding the declaration of large arrays on 32-bit CCG targets. + +2019-07-22 Yannick Moy <moy@adacore.com> + + * sem_ch3.adb (Constrain_Access): Issue a message about ignored + constraint. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch8.adb (End_Use_Type): Reset the In_Use flag on the + class-wide type if the type is tagged. + (Use_One_Type): Add commentary on the handling of the class-wide + type. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * einfo.ads (Is_For_Access_Subtype): Delete. + (Set_Is_For_Access_Subtype): Likewise. + * einfo.adb (Is_For_Access_Subtype): Likewise. + (Set_Is_For_Access_Subtype): Likewise. + (Write_Entity_Flags): Do not write Is_For_Access_Subtype. + * exp_ch4.adb (Expand_N_Selected_Component): Do not deal with + it. + * exp_spark.adb (Expand_SPARK_N_Selected_Component): Likewise. + * sem_ch4.adb (Analyze_Explicit_Dereference): Likewise. + * sem_ch3.adb (Build_Discriminated_Subtype): Do not build a + special private subtype for access-to-record subtypes. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch3.adb (Complete_Private_Subtype): Rework the setting of + the Etype of the full view for full base types that cannot + contain any discriminant. Remove code and comment about it in + the main path. + +2019-07-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Convert_Bound): Subsidiary of + Floating_Point_Type_Declaration, to handle properly range + specifications with bounds that may include static constants of + a given type rather than real literals. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_aggr.adb (Rewrite_Bound): Be prepared for discriminals + too. + (Rewrite_Range;): Minor tweak. + (Resolve_Record_Aggregate): For a component with default + initialization whose expression is an array aggregate, also + rewrite the bounds of the component associations, if any. + +2019-07-22 Gary Dismukes <dismukes@adacore.com> + + * exp_ch5.adb (Expand_N_Case_Statement): In the case where a + case statement is rewritten as an equivalent if statement, + inherit the From_Condition_Expression flag from the case + statement. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch8.adb (Check_Constrained_Object): Further extend the + special optimization to all limited types. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference) + <Attribute_Enum_Val>: Set No_Truncation on the + N_Unchecked_Type_Conversion built around the argument passed to + the attribute. + +2019-07-22 Nicolas Roche <roche@adacore.com> + + * libgnat/s-valrea.adb (Scan_Real): Ignore non significative + digits to avoid converging to infinity in some cases. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/g-encstr.adb (Encode_Wide_String): Fix oversight. + (Encode_Wide_Wide_String): Likewise. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * sem_warn.adb (Find_Var): Bail out for a function call with an + Out or In/Out parameter. + +2019-07-22 Nicolas Roche <roche@adacore.com> + + * terminals.c (__gnat_tty_waitpid): Support both blocking and + not blocking mode. + * libgnat/g-exptty.ads (Is_Process_Running): New function. + * libgnat/g-exptty.adb (Close): Don't try to interrupt/terminate + a process if it is already dead. + +2019-07-22 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Fixed_Point_Type): When freezing a + fixed-point subtype, check whether the parent type declarastion + includes an aspect specification for the 'Small type attribute, + and inherit the specified value. + +2019-07-22 Javier Miranda <miranda@adacore.com> + + * freeze.adb (Freeze_Subprogram): Check that C++ constructors + must have external or link name. + +2019-07-22 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Selected_Component): If the prefix has a + deferred reference, generate the correct reference now, to + indicate that the previous assignment is used. This prevents + spurious warnings on useless assignments when compiling with all + warnings enabled. when there is a subsequent call in the same + stqtement list, in which the prefix of the selected component is + the actual for an out parameter. + +2019-07-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_attr.adb (Expand_Loop_Entry_Attribute): Copy the condition + of a while loop instead of simply relocating it. + +2019-07-18 Arnaud Charlet <charlet@adacore.com> + + * Makefile.rtl, expect.c, env.c, aux-io.c, mkdir.c, initialize.c, + cstreams.c, raise.c, tracebak.c, adadecode.c, init.c, raise-gcc.c, + argv.c, adaint.c, adaint.h, ctrl_c.c, sysdep.c, rtinit.c, cio.c, + seh_init.c, exit.c, targext.c: Introduce a "STANDALONE" mode where C + runtime files do not have any dependency on GCC include files. + Remove unnecessary includes. + Remove remaining references to VMS in runtime C file. + * runtime.h: new File. + +2019-07-13 Andreas Schwab <schwab@linux-m68k.org> + + * Makefile.rtl: Use g-sercom__linux.adb for all linuxes. + +2019-07-11 Piotr Trojanek <trojanek@adacore.com> + + * lib-writ.adb (Ensure_System_Dependency, + Up_To_Date_ALI_File_Exists, Write_ALI): Replace low-level access + to table with a high-level query. + +2019-07-11 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb: Fix typo in comment. + * sem.adb (Semantics): Avoid repeated calls to + In_Extended_Main_Source_Unit by reusing an already-cached + result. + * sem_util.adb (First_Global): Fix style. + +2019-07-11 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Call): Do not perform dimensionality + checking on inlined bodies. + +2019-07-11 Yannick Moy <moy@adacore.com> + + * debug.adb: Flip meaning of debug switch -gnatdF. + +2019-07-11 Yannick Moy <moy@adacore.com> + + * sem_eval.adb (Is_Same_Value): Add special case for rewritten + Loop_Entry attribute. + +2019-07-11 Claire Dross <dross@adacore.com> + + * gnat1drv.adb: SPARK checking rules for pointer aliasing are + moved to GNATprove backend. + * sem_spark.ads, sem_spark.adb (Sem_SPARK): Is now a generic + unit. Takes as parameters: + - Retysp which is used to query the most underlying type + visible in SPARK. We do not introduce aliasing checks for + types which are not visibly deep. + - Component_Is_Visible_In_SPARK is used to avoid doing pointer + aliasing checks on components which are not visible in SPARK. + - Emit_Messages returns True in the second phase of SPARK + analysis. Error messages for failed aliasing checks are only + output in this case. + Additionally, errors on constructs not supported in SPARK are + removed as duplicates of marking errors. Components are stored + in the permission map using their original component to avoid + inconsistencies between components of different views of the + same type. + (Check_Expression): Handle delta constraints. + (Is_Deep): Exported so that we can check for SPARK restrictions + on deep types inside SPARK semantic checkings. + (Is_Traversal_Function): Exported so that we can check for SPARK + restrictions on traversal functions inside SPARK semantic + checkings. + (Check_Call_Statement, Read_Indexes): Check wether we are + dealing with a subprogram pointer type before querying called + entity. + (Is_Subpath_Expression): Image attribute can appear inside a + path. + (Check_Loop_Statement): Correct order of statements in the loop. + (Check_Node): Ignore raise nodes. + (Check_Statement): Use Last_Non_Pragma to get the object + declaration in an extended return statement. + +2019-07-11 Patrick Bernardi <bernardi@adacore.com> + + * bindgen.adb (Gen_Main): Do not generate a reference to + Ada_Main_Program_Name when the Minimal_Binder flag is set. + (Gen_Output_File_Ada): Do not output GNAT_Version and + Ada_Main_Program_Name info if Minimal_Binder flag is set. + * bindusg.adb: Add documentation for new -minimal switch. + * gnatbind.adb (Scan_Bind_Arg): Scan -minimal switch. + * opt.ads: Add new global flag Minimal_Binder to indicate if the + binder should not produce global variables. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Update documentation with new binder -minimal switch. + * gnat_ugn.texi: Regenerate. + +2019-07-11 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl: Add warning note about compilation flags and + capitalize. + +2019-07-11 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.adb (Expand_N_Protected_Type_Declaaration): New + subsidiary routine Replace_Access_Definition, to handle properly + a protected type PT one of whose private components is of type + access PT. + +2019-07-11 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-socket.ads (Level_Type): Add enumerators for + IP_Protocol_For_ICMP, IP_Protocol_For_IGMP, + IP_Protocol_For_RAW_Level. + * libgnat/g-socket.adb (Levels): Handle them. + * s-oscons-tmplt.c: Import socket protocols defined in + netinet/in.h. + +2019-07-11 Claire Dross <dross@adacore.com> + + * libgnat/a-cfhama.adb, libgnat/a-cfhase.adb (Free): Do not + reset the Has_Element flag if no element is freed. + +2019-07-11 Arnaud Charlet <charlet@adacore.com> + + * errno.c: Remove obsolete support for MaRTE OS. + +2019-07-11 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): If a predicate check + is generated, analyze it with range check suppressed, because + that check has been previously applied. + * exp_ch5.adb (Expand_N_Assignment_Statement): If the RHS is a + type conversion to the type of the LHS, do not apply a predicate + check to the RHS because it will have been generated already + during its expansion. + * exp_ch6.adb (Can_Fold_Predicate_Call): Extend processing to + handle a predicate check on a constant entity whose value is + static. + +2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo.adb: Remove the documentation of switch -d_N because it + is no longer in use. + * bindo-graphs.ads, bindo-graphs.adb (Is_Spec_Before_Body_Edge): + New routine. + * bindo-writers.adb (Write_Dependency_Edge): Add the missing + case of a spec-before-body edge. + +2019-07-11 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-socket.ads (Mode_Type): Add a Socket_Raw enumerator. + * libgnat/g-socket.adb (Modes): Handle Socket_Raw. + +2019-07-11 Justin Squirek <squirek@adacore.com> + + * exp_ch9.adb (Build_Private_Protected_Declaration): Add + exception for the moving of pragmas to internally generated + specs for pragma Unreferenced. + +2019-07-11 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Fix inconsistent + documentation for gnatmetric. + * gnat_ugn.texi: Regenerate. + +2019-07-11 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Document gnatpp's + --spaces-only switch. + +2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_util.adb (Null_Status): Assume that an erroneous construct + has an undefined null status. + +2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb, exp_ch6.adb, gnat1drv.adb, sem_aux.adb, + sem_ch2.adb, sem_ch8.adb, sem_res.adb: Minor reformatting. + +2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch8.adb (Analyze_Object_Renaming): Obtain the object being + renamed using routine Get_Object_Name which takes care of + various name forms. + (Get_Object_Name): New routine. + +2019-07-11 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Can_Fold_Predicate_Call): New function, + subsidiary of Expand_Call_Helper, to compute statically a + predicate check when the argument is a static integer. + +2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Resolve_Op_Not): Do not rewrite an equality + operator into a function call when the operator is intrinsic. + +2019-07-11 Thomas Quinot <quinot@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case pragma Check): Do not call + Set_SCO_Pragma_Enabled for the dynamic predicate case. + +2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.ads, exp_util.adb (Needs_Finalization): Move to + Sem_Util. + * sem_ch9.adb (Analyze_Protected_Definition): Code cleanup. Mark + the protected type as having controlled components when it + contains at least one such component. + * sem_util.ads, sem_util.adb (Needs_Finalization): New + function. + +2019-07-11 Eric Botcazou <ebotcazou@adacore.com> + + * alloc.ads (Rep_JSON_Table_Initial): New constant. + (Rep_JSON_Table_Increment): Likewise. + * debug.adb: Document -gnatd_j switch. + * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Add + repinfo-input.o. + * gnat1drv.adb: Add with clause for Repinfo.Input. + Add with and use clauses for Sinput. + (Read_JSON_Files_For_Repinfo): New procedure. + (Gnat1drv1): Deal with -gnatd_j switch. + * repinfo-input.ad[sb]: New unit. + * snames.ads-tmpl (Name_Discriminant): New constant. + (Name_Operands): Likewise. + +2019-07-11 Justin Squirek <squirek@adacore.com> + + * checks.adb (Apply_Accessibility_Check): Add check for constant + folded conditions on accessibility checks. + +2019-07-11 Arnaud Charlet <charlet@adacore.com> + + * libgnarl/g-thread.ads, libgnarl/g-thread.adb (Get_Thread): + Update comments. Add new version taking a Task_Id. + +2019-07-11 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo.adb: Update the section of switches and debugging + elaboration issues. + * bindo.ads: Add type Elaboration_Phase. + * bindo-augmentors.adb: Add use clause for + Bindo.Writers.Phase_Writers. + (Augment_Library_Graph): Signal the start and end of the + aubmentation phase. + * bindo-builders.adb: Add with and use clause for Bindo.Writers. + Add use clause for Bindo.Writers.Phase_Writers. + (Build_Invocation_Graph): Signal the start and end of the + invocation graph construction phase. + (Build_Library_Graph): Signal the start and end of the library + graph construction phase. + * bindo-diagnostics.adb: Add use clause for + Bindo.Writers.Phase_Writers. + (Diagnose_Cycle): Signal the start and end of the cycle + diagnostic phase. + * bindo-elaborators.adb: Add use clause for + Bindo.Writers.Phase_Writers. + (Elaborate_Units): Signal the start and end of the unit + elaboration phase. + * bindo-graphs.adb: Add use clause for + Bindo.Writers.Phase_Writers. + (Find_Components): Signal the start and end of the component + discovery phase. + (Find_Cycles): Signal the start and end of the cycle discovery + phase. + * bindo-units.adb: Add with and use clause for Bindo.Writers. + Add use clause for Bindo.Writers.Phase_Writers. + (Collect_Elaborable_Units): Signal the start and end of the unit + collection phase. + * bindo-validators.adb: Add with and use clause for + Bindo.Writers. Add use clause for Bindo.Writers.Phase_Writers. + (Validate_Cycles, Validate_Elaboration_Order, + Validate_Invocation_Graph, Validate_Library_Graph): Signal the + start and end of the libray graph validation phase. + * bindo-writers.ads, bindo-writers.adb: Add new nested package + Phase_Writers. + * debug.adb: Update the documentation of switch d_S. + +2019-07-11 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Check_Argument_Order): Special case calls to + operators. + +2019-07-10 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/s-ststop.adb: Remove System.Strings.Stream_Ops + dependence on System.Streams.Stream_IO. + +2019-07-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch2.adb (Analyze_Integer_Literal): Preserve the type of + the literal if prior analysis determined that its type is a + modular integer type. + +2019-07-10 Doug Rupp <rupp@adacore.com> + + * init.c: Do not attempt to re-arm guard page on x86_64-vx7(r2). + +2019-07-10 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Check_Constrained_Object): A record that is + limited because of the presence of a limited component is + constrained, and no subtype indiciation needs to be created for + it, just as is the case for declared limited records. + +2019-07-10 Yannick Moy <moy@adacore.com> + + * sem_aux.adb, sem_aux.ads (Is_Protected_Operation): New + function to determine if a subprogram is protected. + * sem_spark.adb (Setup_Protected_Components): New procedure to + add protected components to the environment. + (Check_Callable_Body): Call the new Setup_Protected_Components. + (Check_Package_Spec): Merge local environment with enclosing one + when done. + +2019-07-10 Claire Dross <dross@adacore.com> + + * sem_spark.adb (Check_Expression): Allow digits constraints as + input. + (Illegal_Global_Usage): Pass in the entity. + (Is_Subpath_Expression): New function to allow different nodes + as inner parts of a path expression. + (Read_Indexes): Allow concatenation and aggregates with box + expressions. Allow attributes Update and Loop_Entry. + (Check_Expression): Allow richer membership test. + (Check_Node): Ignore bodies of generics. + (Get_Root_Object): Allow concatenation and attributes. + +2019-07-10 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Check_Discriminant_Conformance): Use Find_Type to + discover the type of a full view discriminant. + +2019-07-10 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/gnat_and_program_execution.rst: Improve gnatmem's + doc for the depth switch. + +2019-07-10 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Document gnatpp's + --source-line-breaks switch. + +2019-07-10 Justin Squirek <squirek@adacore.com> + + * doc/gnat_rm/implementation_defined_attributes.rst: Add mention + of 'Image attribute with 'Img's entry to mention additional + added 2012 usage of Obj'Image. + * doc/gnat_rm/implementation_defined_pragmas.rst: Correct + mispelling of Async_Writers. + * gnat_rm.texi: Regenerate. + * sem_prag.adb (Analyze_Pragma): Correct mispelling of + Async_Writers. + * sem_util.adb (State_Has_Enabled_Property): Correct mispelling + of Async_Writers. + +2019-07-10 Simon Buist <buist@adacore.com> + + * sem_util.ads (Child_Prefix): New constant. + * sem_util.adb (Unique_Name): Add a special prefix to child + units that have a nested subprogram or package. + +2019-07-10 Arnaud Charlet <charlet@adacore.com> + + * sfn_scan.adb (Scan_SFN_Pragmas): Add pragma Assert. + +2019-07-10 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb (Check_Nonoverridable_Aspects): Correct the + spelling in certain error messages. + (Check_Pragma_Implemented): Correct the spelling in certain + error messages. + +2019-07-10 Eric Botcazou <ebotcazou@adacore.com> + + * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Add g-brapre. + * libgnat/g-brapre.ads: New package specification. + * doc/gnat_rm/the_gnat_library.rst: Document it. + * gnat_rm.texi: Regenerate. + +2019-07-10 Yannick Moy <moy@adacore.com> + + * osint-c.adb (Set_File_Name): Always add extension for multiple + units per file mode. + +2019-07-10 Corentin Gay <gay@adacore.com> + + * sysdep.c: Put include directive for 'vxWorks.h' before any + other VxWorks headers. + +2019-07-10 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_attributes.rst + (Scalar_Storage_Order): Minor tweaks. Add note about debuggers. + * gnat_rm.texi: Regenerate. + +2019-07-10 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Expand_N_Case_Expression): Mark the generated + assignments to the temporary result as being OK because the + expansion of case expressions is correct by construction. + (Is_Copy_Type): Update the predicate to match the comment + within. + +2019-07-10 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo-graphs.adb, bindo.adb, debug.adb, exp_ch6.adb, + sem_ch10.adb, sem_ch13.adb, sem_ch3.adb, sem_ch4.adb, + sem_ch6.adb, sem_ch7.adb, sem_res.adb, sem_spark.adb, + sem_util.adb, warnsw.ads: Minor reformatting. + +2019-07-10 Joffrey Huguet <huguet@adacore.com> + + * libgnat/a-strbou.ads, libgnat/a-strfix.ads, + libgnat/a-strunb.ads, libgnat/a-strunb__shared.ads: Add global + contracts, contract cases, preconditions and postconditions to + procedures and functions. + +2019-07-10 Doug Rupp <rupp@adacore.com> + + * sysdep.c (__gnat_is_file_not_found_error): Reformulate to also + work for vxworks7r2 SR0610. + +2019-07-10 Doug Rupp <rupp@adacore.com> + + * env.c (__gnat_environ): Reformulate to also work for + vxworks7r2 SR0610. + +2019-07-10 Patrick Bernardi <bernardi@adacore.com> + + * Makefile.rtl: Handle vxworks7r2 ppc target + +2019-07-10 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo.adb: Update the section on switches. + * bindo-graphs.adb + (Add_Cycle, Add_Vertex_And_Complement): Remove. + (Create): The graph no longer needs a set of recorded cycles + because the cycles are not rediscovered in permuted forms. + (Cycle_End_Vertices): New routine. + (Destroy): The graph no longer needs a set of recorded cycles + because the cycles are not rediscovered in permuted forms. + (Destroy_Library_Graph_Vertex): Move to the library level. + (Find_All_Cycles_Through_Vertex, Find_All_Cycles_With_Edge): + Remove. + (Find_Cycles_From_Successor, Find_Cycles_From_Vertex, + Find_Cycles_In_Component, Has_Elaborate_All_Edge): New routines. + (Insert_And_Sort): Remove. + (Is_Elaborate_Body_Edge): Use predicate + Is_Vertex_With_Elaborate_Body. + (Is_Recorded_Cycle): Remove. + (Is_Vertex_With_Elaborate_Body): New routine. + (Normalize_And_Add_Cycle): Remove. + (Precedence): Rename to xxx_Precedence, where xxx relates to the + input. These versions better reflect the desired input + precedence. + (Record_Cycle): New routine. + (Remove_Vertex_And_Complement, Set_Is_Recorded_Cycle): Remove. + (Trace_xxx): Update all versions to use debug switch -d_t. + (Trace_Component): New routine. + (Trace_Eol): Removed. + (Trace_Vertex): Do not output the component as this information + is already available when the component is traced. + (Unvisit, Visit): New routine. + * bindo-graphs.ads: Add new instance LGV_Lists. Remove instance + RC_Sets. Update the structure of type Library_Graph_Attributes + to remove the set of recorded cycles. + (Destroy_Library_Graph_Vertex): Move to the library level. + * bindo-writers.adb (Write_Component_Vertices): Output + information about the number of vertices. + * debug.adb: Document the use of binder switch -d_t. Update the + use of binder switch -d_T. + +2019-07-10 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Get_Root_Object): Replace precondition by error + message. + (Read_Indexes): Replace precondition by error message. + (Check_Callable_Body): Check only traversal function returns an + anonymous access type. + (Check_Expression): Issue error on unexpected expression as + path. + * sem_util.adb (First_Global): Fix access to global on + entry/task. + +2019-07-10 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Is_Class_Wide_Interface_Type): New subprogram. + (Expand_Call_Helper): Handle non-limited views when we check if + any formal is a class-wide interface type. + * exp_disp.adb (Expand_Interface_Actuals): Handle non-limited + views when we look for interface type formals to force "this" + displacement. + +2019-07-10 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Equality_Op): Do not replace the resolved + operator by its alias if expander is not active, because the + operand type may not be frozen yet and its inherited operations + have not yet been created. + +2019-07-10 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo-elaborators.adb (Elaborate_Units): Set attribute + Elab_Position of all elaborated units. + (Set_Unit_Elaboration_Positions): New routine. + +2019-07-10 Gary Dismukes <dismukes@adacore.com> + + * exp_util.adb: Reformatting and a typo fix. + +2019-07-10 Yannick Moy <moy@adacore.com> + + * exp_util.adb (Remove_Side_Effects): Prefer renamings for + objects of possible owning type in GNATprove mode. + +2019-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Analyze_Object_Declaration): If the object type + is a composite type that has a dynamic predicate and, the + expression in the declaration is an aggregate, the generated + predicate check must appear after the expanded code for the + aggregate, which will appear after the rewritten object + declarastion. + +2019-07-09 Justin Squirek <squirek@adacore.com> + + * sem_eval.adb (Expr_Value_E): Add conditional to correctly + handle constant enumerated character types. + +2019-07-09 Eric Botcazou <ebotcazou@adacore.com> + + * libgnarl/s-osinte__mingw.ads (CRITICAL_SECTION): Use proper + type for SpinCount component. + +2019-07-09 Justin Squirek <squirek@adacore.com> + + * exp_ch4.adb (Expand_N_Allocator): Add conditional to detect + the presence of anoymous access type allocators and issue a + warning if the appropriate warning flag is enabled. + * warnsw.ads: Add new warning flag for anonymous allocators + * warnsw.adb (All_Warnings, Restore_Warnings, Save_Warnings, + Set_Underscore_Warning_Switch): Register new flags. + (WA_Warnings): Register new flag as an "all warnings" switch + * usage.adb, + doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Document new warning switches -gnatw_a and -gnatw_A. + * gnat_ugn.texi: Regenerate. + +2019-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Diagnose_Call): Improve error recovery when a + local subprogram name hides a possible candidate name declared + in a child package in the context of the current unit. + * sem_ch6.adb (Process_Formals): Protect against malformed + formal types when the parameter type does not denote an entity. + +2019-07-09 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo-augmentors.adb (Visit_Elaboration_Root): Do not start a + DFS from an elaboration root whose corresponding unit lacks + elaboration code. This behavior mimics that of the old + elaboration order mechanism. + * bindo-graphs.adb (Find_All_Cycles_Through_Vertex): Move the + vertex tracing within the functional branches of the routine. + This prevents spurious trace output. + (Has_No_Elaboration_Code): New routine. + (Trace_Cycle, Trace_Edge): Update the various Ids to use the + "standard" trace format. + * bindo-graphs.ads (Has_No_Elaboration_Code): New routine. + * bindo-units.ads, bindo-units.adb (Has_No_Elaboration_Code): + New routine. + +2019-07-09 Piotr Trojanek <trojanek@adacore.com> + + * ali.ads, bindo-graphs.adb, bindo-validators.adb, clean.adb, + doc/gnat_ugn/elaboration_order_handling_in_gnat.rst, einfo.ads, + exp_aggr.adb, exp_ch13.adb, exp_ch4.adb, exp_ch5.adb, + exp_ch6.adb, exp_ch7.adb, exp_ch9.adb, exp_pakd.adb, + fname-uf.ads, gnatlink.adb, inline.adb, lib.ads, make.adb, + namet.ads, opt.ads, par-ch4.adb, par-ch6.adb, par-labl.adb, + prep.adb, sem_aggr.adb, sem_ch13.adb, sem_ch4.adb, sem_ch5.adb, + sem_ch6.adb, sem_ch6.ads, sem_ch7.adb, sem_ch8.adb, sem_dim.adb, + sem_disp.adb, sem_prag.adb, sem_res.adb, sem_warn.adb, + sinfo.ads: Replace ". " with ". ". Minor reformatting and typo + corrections. + * gnat_ugn.texi: Generate. + +2019-07-09 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo.ads: Move type Precedence_Kind from the private to the + visible part of the unit. + * bindo-augmentors.adb: Remove the use of global data as it is + bad practice. + (Augment_Library_Graph): Update the parameter profile. + (Is_Visited, Set_Is_Visited): Remove. + (Visit_Elaboration_Root, Visit_Elaboration_Roots): Update the + parameter profile and comment on usage. + (Visit_Vertex): Likewise. Also keep track of which invocation + edge activates a task. + * bindo-augmentors.ads (Augment_Library_Graph): Update the + parameter profile and comment on usage. + * bindo-builders.adb (Create_Forced_Edge, + Create_Spec_And_Body_Edge, Create_With_Edge): Update the call to + Add_Edge. + * bindo-diagnostics.adb: Add with end use clauses for Restrict + and Rident. + (Output_Dynamic_Model_Suggestions): Remove. + (Output_Invocation_Related_Suggestions): New routine. + (Output_Suggestions): Output all invocation-related suggestions + together. + * bindo-elaborators.adb: Remove types Comparator_Ptr and + Predicate_Ptr. + (Find_Best_Vertex): Update the parameter profile. + * bindo-graphs.adb (Activates_Task): New routine. + (Add_Body_Before_Spec_Edge): Update the call to + Add_Edge_With_Return. + (Add_Edge): Update the parameter profile and the call to + Add_Edge_With_Return. + (Add_Edge_With_Return): Update the parameter profile and comment + on usage. + (At_Least_One_Edge_Satisfies): New routine. + (Contains_Elaborate_All_Edge): Reimplement. + (Contains_Static_Successor_Edge, Contains_Task_Activation): New + routine. + (Contains_Weak_Static_Successor): Remove. + (Is_Static_Successor_Edge): New routine. + * bindo-graphs.ads: Add types LGE_Predicate_Ptr, + LGV_Comparator_Ptr, and LGV_Predicate_Ptr. Update type + Library_Graph_Edge_Attributes to capture whether an invocation + edge activates a task. Update the value of + No_Library_Graph_Edge_Attributes. + (Activates_Task): Update the parameter profile and comment on + usage. + (Contains_Static_Successor_Edge, Contains_Task_Activation): New + routines. + (Contains_Weak_Static_Successor): Remove. + * doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: + Update the documentation to reflect the new task-related advice. + * gnat_ugn.texi: Regenerate. + +2019-07-09 Piotr Trojanek <trojanek@adacore.com> + + * exp_util.adb (Containing_Package_With_Ext_Axioms): Replace + low-level Ekind test with a high-level wrapper. + +2019-07-09 Arnaud Charlet <charlet@adacore.com> + + * libgnat/s-memory.adb: Disable calls to Abort defer/undefer + when ZCX_By_Default. + +2019-07-09 Javier Miranda <miranda@adacore.com> + + * sem_ch13.adb (Rep_Item_Too_Early): Representation clauses are + not allowed for a derivation of a generic type. Extend the + current test to check that none of the parents is a generic + type. + +2019-07-09 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch9.adb, exp_util.adb, repinfo.adb, sem_ch12.adb, + sem_prag.adb, sem_res.adb, sem_spark.adb, sem_util.adb: Minor + reformatting. + +2019-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Equality_Op): If the node was overloaded, + set properly the entity to which the node has been resolved. The + original entity is the first one found during analysis, and is + not necessarily the resolved one. + (Resolve_Op_Not): If the argument of negation is an overloaded + equality operation, call its resolution directly given that the + context type does not participate in overload resolution. + +2019-07-09 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo.adb: Remove with and use clauses for Debug. Add with + and use clauses for Opt. + (Find_Elaboration_Order): Enable the v4.0 elaboration order. The + v3.0 mechanism is now available under binder switch -H. + * bindusg.adb (Display): Enable switch -H. + * debug.adb: Free compiler switch -gnatd_G. Free binder switch + -d_N. + * sem_elab.adb: Update the section on switches to remove + -gnatd_G. + (Invocation_Graph_Recording_OK): The invocation graph is now + unconditionally recorded in ALI files. + * switch-b.adb (Scan_Binder_Switches): Scan switch -H. + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Update the documentation on compiler switches related to + elaboration. Update the documentation on binder switches to + include switch -H. + * doc/gnat_ugn/elaboration_order_handling_in_gnat.rst: Update + the documentation on elaboration order handling in GNAT. + * gnat_ugn.texi: Regenerate. + +2019-07-09 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.adb (List_Entities): Disregard formals altogether. + (List_Name): Properly escape the double quote in the JSON + output. + +2019-07-09 Javier Miranda <miranda@adacore.com> + + * exp_util.adb (Remove_Side_Effects): Preserve the + Do_Range_Check flag. + +2019-07-09 Yannick Moy <moy@adacore.com> + + * sinfo.ads: Refine comment for Do_Range_Check. + +2019-07-09 Yannick Moy <moy@adacore.com> + + * exp_spark.adb (Expand_SPARK_N_Attribute_Reference): Expand + attribute reference on Enum_Rep. + +2019-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Instantiate_Formal_Package): Handle properly the + case where the actual for a formal package in an instance is the + current instance of an enclosing generic package. + (Check_Formal_Packages): If the formal package declaration is + box-initialized or lacks associations altogether, no internal + instance was created to verify conformance, and there is no + validating package to remove from tree. + +2019-07-09 Yannick Moy <moy@adacore.com> + + * freeze.adb (Build_Renamed_Body): Do not set body to inline in + GNATprove mode. + +2019-07-09 Yannick Moy <moy@adacore.com> + + * exp_util.adb (Expand_Subtype_From_Expr): Still expand the type + of static expressions in GNATprove_Mode. + * sem_ch3.adb (Analyze_Object_Declaration): Remove obsolete + special case for GNATprove_Mode. + +2019-07-09 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_rm/the_gnat_library.rst, + doc/gnat_ugn/building_executable_programs_with_gnat.rst, + erroutc.adb, libgnat/g-comlin.adb, libgnat/g-comlin.ads, + libgnat/g-regexp.ads, libgnat/g-regpat.ads, + libgnat/g-spipat.ads, libgnat/s-os_lib.ads, + libgnat/s-regexp.ads: Reword "wild card" to "wildcard". + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + +2019-07-09 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Check_Expression): Handle correctly implicit + assignments as part of allocators and (extension) aggregates. + (Get_Root_Object): Adapt for new path expressions. + (Is_Path_Expression): Return True for (extension) aggregate. + +2019-07-09 Piotr Trojanek <trojanek@adacore.com> + + * einfo.ads: Fix a typo. + +2019-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Scope_Within_Or_Same): Handle properly task + bodies and protected bodies, so that local variables within have + their proper scopes after these constructs have been rewritten + during expansion. This patch resembles but is not identical to + the code in Scope_Within. + +2019-07-09 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Set + Dynamic_Elaboration_Checks to True in CodePeer mode. + +2019-07-09 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Get_Perm_Or_Tree): Issue an error when + encountering unknown global variable. + +2019-07-09 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Check_Expression): Change signature to take an + Extended_Checking_Mode, for handling read permission checking of + sub-expressions in an assignment. + (Check_Parameter_Or_Global): Adapt to new behavior of + Check_Expression for mode Assign. + (Check_Safe_Pointers): Do not analyze generic bodies. + (Check_Assignment): Separate checking of the target of an + assignment. + +2019-07-09 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.ads (JSON format): Adjust. + * repinfo.adb (Need_Blank_Line): Rename to... + (Need_Separator): ...this. + (Blank_Line): Rename to... + (Write_Separator): ...this and add JSON specific handling. + (List_Array_Info): Adjust to above renaming. + (List_Object_Info): Likewise. + (List_Record_Info): Likewise. + (List_Subprogram_Info): Likewise. + (List_Type_Info): Likewise. + (List_Entities): Do not set Need_Blank_Line. + (List_Rep_Info): Set Need_Separator and add JSON specific + handling. Output a single JSON stream in the normal case. + +2019-07-09 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/the_gnat_compilation_model.rst: Update doc on + -fdump-ada-spec now that we generate Ada 2012. + * gnat_ugn.texi: Regenerate. + +2019-07-08 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.adb (List_Common_Type_Info): New procedure extracted + from... + (List_Type_Info): ...here. Call it for the common information, + start with a blank line and output the linker section at the + end, if any. + (List_Mechanisms): Rename to... + (List_Subprogram_Info): ...this. + (List_Array_Info): Call List_Common_Type_Info. + (List_Entities): Adjust to above change and renaming. + (List_Record_Info): Call List_Common_Type_Info. + +2019-07-08 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-sercom.ads + (Serial_Port_Descriptor): New type. + (Serial_Port): Add a comment, make it hold a + Serial_Port_Descriptor. + (To_Ada, To_C): New procedures. + (Port_Data, Port_Data_Access): Remove types. + * libgnat/g-sercom.adb (To_Ada): New stub. + * libgnat/g-sercom__linux.adb, libgnat/g-sercom__mingw.adb: + Update implementations accordingly. + * s-oscons-tmplt.c: Bind Serial_Port_Descriptor to + System.Win32.HANDLE on Windows, and to Interfaces.C.int on + Linux. Add "Interfaces.C." prefix for other basic integer type + bindings. + * xoscons.adb (Output_Info): Remove the "Interfaces.C." prefix + for subtypes generation. + +2019-07-08 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst: + Update documentation on No_Exceptions restriction. + * gnat_rm.texi: Regenerate. + +2019-07-08 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/s-os_lib.adb: Do not call __gnat_kill for Invalid_Pid. + +2019-07-08 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Enclosing_Package_Or_Subprogram): Do not expect + package and subprogram bodies. + +2019-07-08 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Remove documentation + of ignored GNATpp switch. + +2019-07-08 Hristian Kirtchev <kirtchev@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: + Update the documentation of pragma Initialize_Scalars. + * gnat_rm.texi: Regenerate. + +2019-07-08 Javier Miranda <miranda@adacore.com> + + * exp_ch4.adb (Tagged_Membership): Fix regression silently + introduced in r260738 that erroneouslusy causes the evaluation + to True of the membership test when the left operand of the + membership test is a class-wide interface object and the right + operand is a type that implements such interface type. + +2019-07-08 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not + register an address clause when its prefix denotes a generic + formal object. + +2019-07-08 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo-diagnostics.adb (Diagnose_Cycle): Capture the presence + of an Elaborate_All edge before iterating over the edges of the + cycle. + (Output_Elaborate_Body_Transition): Update the parameter profile + and the comment on usage. Add a missing case where the edge is + within the context of an Elaborate_All. + (Output_Transition): Update the call to + Output_Elaborate_Body_Transition. + * bindo-graphs.ads, bindo-graphs.adb + (Contains_Elaborate_All_Edge): New routine. + +2019-07-08 Piotr Trojanek <trojanek@adacore.com> + + * lib-xref-spark_specific.adb (Create_Heap): Set dummy Etype for + the fake __HEAP entity. + +2019-07-08 Daniel Mercier <mercier@adacore.com> + + * gnat1drv.adb: Suppress warnings on memory representation in + CodePeer compiler mode. + +2019-07-08 Nicolas Roche <roche@adacore.com> + + * rtinit.c (__gnat_runtime_initialize): Remove dependency on + CommandLineToArgvW. + +2019-07-08 Doug Rupp <rupp@adacore.com> + + * Makefile.rtl: Handle vxworks7r2 in x86_64 and x86 vxworks7. + +2019-07-08 Dmitriy Anisimkov <anisimko@adacore.com> + + * Makefile.rtl: Use g-sercom__linux.adb for all linuxes. + +2019-07-08 Yannick Moy <moy@adacore.com> + + * expander.adb (Expand): Do not reset Analyzed flag always. + * sem_eval.adb (Fold_Ureal): Mark node as analyzed. + +2019-07-08 Ed Schonberg <schonberg@adacore.com> + + * exp_ch9.adb (Expand_N_Timed_Entry_Call): Do not insert twice + the assignment statement that computes the delay value, to + prevent improper tree sharing when the value is a type + conversion and Float_Overflow checks are enabled. + +2019-07-08 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo.adb: Update the section on terminology to include new + concepts. Update the section on switches to include new + entries. + * bindo.ads: Add type Precedence_Kind. + * bindo-builders.adb: Add with and use clauses for Debug and + Bindo.Validators. Add use clauses for + Bindo.Validators.Invocation_Graph_Validators and + Bindo.Validators.Library_Graph_Validators. + (Build_Invocation_Graph): Validate the graph immediately after + it was built. + (Build_Library_Graph): Update the parameter profile. The + creation of the graph is now elaboration model-agnostic. + Validate the graph immediately after it was built. + (Create_With_Edge): Create regular with edges for Elaborate and + Elaborate_All edges when the appropriate debug switches are in + effect. + * bindo-builders.ads (Build_Library_Graph): Update the parameter + profile. + * bindo-diagnostics.adb (Diagnose_Cycle): Track the presence of + an Elaborate_All edge throughout the inspection of the cycle's + edges. + (Output_Dynamic_Model_Suggestions): Output the suggestion only + when the cycle contains at least one weak edge where the + successor was statically elaborated. + (Output_Elaborate_Body_Transition, Output_Forced_Transition, + Output_With_Transition): Update the assertions. + * bindo-elaborators.adb: Remove use clauses for + Bindo.Validators.Invocation_Graph_Validators and + Bindo.Validators.Library_Graph_Validators. Remove strings + Add_To_All_Candidates_Msg and Add_To_Comp_Candidates_Msg. + Remove type String_Ptr. + (Add_Vertex, Add_Vertex_If_Elaborable, Create_All_Candidates_Set + Create_Component_Candidates_Set): Remove. + (Create_Component_Vertex_Sets, Create_Vertex_Sets): New routine. + (Elaborate_Component): Update the parameter profile and the + comment on usage. Reimplement the elaboration of a component. + The algorithm will now attempt to elaborate as many vertices + possible. If this is not possible, and a weakly elaborable + vertex is available use unit was compiled using the dynamic + model, the algorithm will elaborate it. + (Elaborate_Library_Graph): Reimplement the elaboration of the + graph. The algorithm will now attempt to elaborate as many + vertices along with their components as possible. If this is not + possible, and a weakly elaborable vertex is available use unit + was compiled using the dynamic model, the algorithm will + elaborate it along with its component. + (Elaborate_Units): Merge with the functionality of + Elaborate_Units_Common. + (Elaborate_Units_Common, Elaborate_Units_Dynamic, + Elaborate_Units_Static): Remove. + (Elaborate_Vertex): Update the parameter profile and the comment + on usage. Reimplemented. + (Find_Best_Candidate): Remove. + (Find_Best_Elaborable_Vertex, Find_Best_Vertex, + Find_Best_Weakly_Elaborable_Vertex, Has_Elaborable_Body, + Insert_Elaborable_Successor, Insert_Vertex): New routines. + (Is_Better_Candidate): Remove. + (Is_Better_Elaborable_Vertex, + Is_Better_Weakly_Elaborable_Vertex, + Is_Suitable_Elaborable_Vertex, + Is_Suitable_Weakly_Elaborable_Vertex): New routines. + (Trace_Candidate_Vertices): Remove. + (Trace_Component): Output the number of strong and weak + predecessors. + (Trace_Unelaborated_Vertices): Remove. + (Trace_Vertex): Output the number of strong and weak + predecessors. + (Trace_Vertices): New routine. + (Update_Successor, Update_Successors): Update the parameter + profile and the comment on usage. + * bindo-graphs.adb: Remove type Precedence_Kind. + (Add_Edge_With_Return): Update the increment of pending + predecessors. + (Add_Vertex): Provide default values for strong and weak + predecessors. + (Complementary_Vertex): Move the initial declaration to the + spec. Update the parameter profile and the comment on usage. + (Contains_Weak_Static_Successor): New routine. + (Create): Update the parameter profile. The creation of the + graph is now elaboration model-agnostic. + (Decrement_Pending_Predecessors): Update the parameter profile + and the comment on usage. Reimplemented. + (Delete_Edge): Update the decrement of pending predecesors. + (Has_Elaborate_Body): Do not treat a vertex as being subject to + Elaborate_Body when a debug switch is in effect. + (Increment_Pending_Predecessors): Update the parameter profile + and the comment on usage. Reimplemented. + (Is_Elaborable_Component): Reimplemented. + (Is_Elaborable_Vertex): Move the initial declaration to the + spec. Reimplemented. + (Is_Elaborate_Body_Pair): New routine. + (Is_Dynamically_Elaborated): Update the parameter profile. + Reimplemented. + (Is_Weakly_Elaborable_Vertex): New routine. + (Pending_Predecessors): Removed. + (Pending_Predecessors_For_Elaboration, + Pending_Strong_Predecessors, Pending_Weak_Predecessors, + Update_Pending_Predecessors): New routines. + (Update_Pending_Predecessors_Of_Components): Update the + increment of pending predecessors. + * bindo-graphs.ads: Update the components of type + Component_Attributes. Update the components of type + Library_Graph_Attributes. Update the components of type + Library_Graph_Vertex_Attributes. Update the initialization of + No_Component_Attributes. Update the initialization of + No_Library_Graph_Vertex_Attributes. + (Complementary_Vertex, Contains_Weak_Static_Successor): New + routines. + (Create): Update the parameter profile and the comment on usage. + (Decrement_Pending_Predecessors, Is_Dynamically_Elaborated): + Update the parameter profile and the comment on usage. + (Is_Elaborate_Body_Pair, Is_Weakly_Elaborable_Vertex): New + routines. + (Pending_Predecessors): Removed. + (Pending_Predecessors_For_Elaboration, + Pending_Strong_Predecessors, Pending_Weak_Predecessors): New + routines. + * bindo-writers.adb (Write_Components): Moved from the spec. + (Write_Component): Output the strong and weak predecessors. + (Write_Library_Graph): Output the components as part of the + graph. + (Write_Library_Graph_Vertex): Output the strong and weak + predecessors. + * bindo-writers.ads (Write_Components): Moved to the body. + * debug.adb: Add and document new GNATbind switches -d_a, -d_b, + -d_e. + * bindo-validators.adb: Minor reformattings. + +2019-07-08 Bob Duff <duff@adacore.com> + + * libgnat/g-sercom.ads, libgnat/g-sercom__linux.adb (Data_Rate): + Support additional data rates. + +2019-07-08 Olivier Hainque <hainque@adacore.com> + + * gcc-interface/trans.c (Compilation_Unit_to_gnu): Don't request + DECL_ARTIFICIAL_P on elab proc declarations. + +2019-07-08 Eric Botcazou <ebotcazou@adacore.com> + + * repinfo.adb (List_Record_Info): Declare Incomplete_Layout and + Not_In_Extended_Main local exceptions. + (List_Structural_Record_Layout): For an extension, raise the + former if the parent subtype has not been built and the latter + if it is not declared in the main source unit. Fall back to the + flat layout if either exception has been raised. + +2019-07-08 Ed Schonberg <schonberg@adacore.com> + + * libgnat/a-strfix.adb (Delete): The RM describes the semantics + of Delete as equivalent to that of Replace_String with a null + argument. As a result, deleting a null string that starts past + the end of its argument is a noop and must not raise + Index_Error. + +2019-07-08 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Register_Primitive): When registering a + primitive in the secondary dispatch table, handle primitive + inherited through several levels of type derivation (required to + properly handle inherited 'null' primitive). + +2019-07-08 Bob Duff <duff@adacore.com> + + * doc/gnat_ugn/gnat_utility_programs.rst: Document handling of + preprocessor directives in GNATpp. + +2019-07-08 Javier Miranda <miranda@adacore.com> + + * gnat1drv.adb (Post_Compilation_Validation_Checks: + Validate_Compile_Time_Warning_Errors is now located in sem_prag + (instead of sem_ch13). + * sem_ch13.ads (Validate_Compile_Time_Warning_Error, + Validate_Compile_Time_Warning_Errors): Move to sem_prag. + * sem_ch13.adb + (Compile_Time_Warnings_Errors): Move to sem_prag. + (Initialize): Remove initialization of table + Compile_Time_Warning_Errors. + (Validate_Compile_Time_Warning_Error, + Validate_Compile_Time_Warning_Errors): Move to sem_prag. + * sem_prag.ads (Validate_Compile_Time_Warning_Errors): New + procedure. + * sem_prag.adb (Initialize): Initialize table + Compile_Time_Warning_Errors. + +2019-07-08 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): For a + pre/postcondition of a generic subprogram declaration, do not + use Relocate_Node on the aspect expression to construct the + corresponding attribute specification, to prevent tree anomalies + when the expression is a call with named actual parameters. + +2019-07-08 Javier Miranda <miranda@adacore.com> + + * sem_attr.adb (Analyze_Attribute [Attribute_Size]): For pragmas + used to report user defined compile time warning or errors + handle 'Size for types with known static RM size. + +2019-07-08 Justin Squirek <squirek@adacore.com> + + * exp_imgv.adb (Build_Enumeration_Image_Tables): Default SSO for + the building of image tables. + (Expand_Image_Attribute): Minor cleanup. + +2019-07-08 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-socket.ads, libgnat/g-socket.adb: Improve + documentation. + (Get_Socket_Option, Set_Socket_Option): Remove default value for + the Level formal. + +2019-07-08 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): For an + unanalized aspect in a generic context that has not been + analyzed yet, if the aspect applies to a type, place the type on + the scope stack to make its components visible, before checking + conformance with the version of the expression analyzed at the + freeze point. + +2019-07-05 Justin Squirek <squirek@adacore.com> + + * checks.adb (Apply_Accessibility_Check): Add logic to fetch the + function result accessibility level if one is required within + the generated check. + * exp_ch6.adb (Needs_Result_Accessibility_Level): Modify + controlling elsif block to handle more cases such as anonymous + access results and disable checking for coextensions. + +2019-07-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch9.adb (Analyze_Accept_Statement): If this is an illegal + accept statement for an enclosing entry abandon analysis to + prevent scope mismatches and potential infinite loops in + compiler. + +2019-07-05 Hristian Kirtchev <kirtchev@adacore.com> + + * ali.adb (For_Each_Invocation_Construct, + For_Each_Invocation_Relation): New version. + (Scan_ALI): Initialize field Invocation_Graph_Encoding. + (Set_Invocation_Graph_Encoding): Update the setting of the + invocation graph encoding. + * ali.ads: Move field Invocation_Graph_Encoding from Unit_Record + to ALI_Record because the encoding applies to the whole ALI, + rather than one of the units (spec or body) for which the ALI + file was created. + (For_Each_Invocation_Construct, For_Each_Invocation_Relation): + New version. + * bindo.adb: Update the section on switches. Complete the + section of debugging elaboration order issues. + (Find_Elaboration_Order): Prepare the routine for the switch + from the old to the new elaboration order mechanism. + * bindo-diagnostics.adb (Find_And_Output_Invocation_Paths): + Manage a visited set used by Visit_Vertex. + (Output_All_Cycles_Suggestions, + Output_Dynamic_Model_Suggestions): Clarify the nature of the + suggested switch. + (Output_Elaborate_Body_Transition): Update the diagnostic to + emit a better message. + (Output_Forced_Suggestions, Output_Full_Encoding_Suggestions): + Clarify the nature of the suggested switch. + (Visit_Vertex): Update the parameter profile to add a set of + invokers visited during the transition. This set prevents + infinite exploration of the graph in case the invocations are + recursive. + * bindo-elaborators.adb: Add a use clause for + Bindo.Writers.Dependency_Writers. + (Elaborate_Units_Common): Output the library graph after it has + been augmented with invocation edges. Output just the components + instead of outputting the whole library graph again. + (Elaborate_Units_Dynamic, Elaborate_Units_Static): Output the + dependencies as expressed in the library graph. + * bindo-units.adb (Invocation_Graph_Encoding): Update the + extraction of the invocation graph encoding. + * bindo-writers.adb: Add with and use clauses for Binderr and + Butil. + (palgc, plgc): New debug routine. + (Write_Components): Moved to the spec. Add a header for the + output. + (Write_Dependencies, Write_Dependencies_Of_Vertex, + Write_Dependency_Edge): New routine. + (Write_Elaboration_Order): Update the logic to follow the format + of Binde's order output. + (Write_Library_Graph): Do not output the components every time + the graph is written. + (Write_Unit): Output the invocation graph encoding of the unit. + Output the invocation constructs and relations for the unit + only. + * bindo-writers.ads (Write_Components): Moved from the body. + (Write_Dependencies): New routine. + * bindusg.adb: Prepare the routine for the switch from the old + to the new elaboration order mechanism. + * debug.adb: Binder switch -d_O is now not associated with any + functionality. + * einfo.adb (Is_Elaboration_Target): The attribute applies to + packages, as specified by the comment on the attribute usage. + * opt.ads: Add a global flag which controls the choice between + the new and the legacy elaboration order mechanism. + * sem_elab.adb: Add Package_Target to type Target_Kind. + (Build_Elaborate_Body_Procedure, Build_Elaborate_Procedure, + Build_Elaborate_Spec_Procedure, Check_Elaboration_Scenarios, + Check_SPARK_Model_In_Effect): Use Main_Unit_Entity to obtain the + entity of the main unit. + (Create_Package_Rep): New routine. + (Create_Target_Rep): Add processing for packages. + (Declaration_Placement_Of_Node, Has_Prior_Elaboration): Use + Main_Unit_Entity to obtain the entity of the main + unit. + (Invocation_Graph_Recording_OK): Prepare the routine for the + switch from the old to the new elaboration order mechanism. + (Main_Unit_Entity): New routine. + (Meet_Elaboration_Requirement, + Process_Conditional_ABE_Variable_Reference): Use + Main_Unit_Entity to obtain the entity of the main unit. + (Process_Invocation_Instantiation): New routine. + (Process_Invocation_Scenario): Add processing for + instantiations. + * switch-b.adb (Scan_Binder_Switches): Prepare the routine for + the switch from the old to the new elaboration order mechanism. + +2019-07-05 Joffrey Huguet <huguet@adacore.com> + + * libgnat/a-textio.adb: Add abstract state refinment. + * libgnat/a-textio.ads: Add File_System abstract state. Add + global contracts, contract cases, preconditions and + postconditions to procedures and functions. + (Set_Input, Set_Output, Set_Error, Standard_Input, + Standard_Output, Standard_Error, Current_Input, Current_Output, + Current_Error): Turn SPARK_Mode off. + (Get_Line): Turn SPARK_Mode off on Get_Line functions. + * libgnat/a-tideio.ads, libgnat/a-tienio.ads, + libgnat/a-tifiio.ads, libgnat/a-tiflio.ads, + libgnat/a-tiinio.ads, libgnat/a-timoio.ads: Add global + contracts, contract cases, preconditions and postconditions to + procedures and functions. + +2019-07-05 Arnaud Charlet <charlet@adacore.com> + + * doc/gnat_ugn/platform_specific_information.rst: Refresh doc on + installing from the command line on Windows. Remove obsolete + part. + * gnat_ugn.texi: Regenerate. + +2019-07-05 Vasiliy Fofanov <fofanov@adacore.com> + + * libgnat/a-wichha.ads (Is_Alphanumeric): Replace comment with + the correct one. Also capitalize references to False + throughout. + +2019-07-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Expand_N_Indexed_Component): Do not expand actual + parameters of function calls here either. + +2019-07-05 Hristian Kirtchev <kirtchev@adacore.com> + + * bindo-units.adb, checks.adb, exp_attr.adb, exp_ch3.adb, + exp_ch4.adb, exp_pakd.adb, lib-writ.adb, libgnat/g-traceb.adb, + libgnat/g-traceb.ads, libgnat/s-stratt.ads, sem_aux.ads, + sem_util.adb: Minor reformatting. + +2019-07-05 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Build_Predicate_Functions): If a subtype that + carries a static predicate aspect is frozen immediately after + its declaration, ensure that the generated function body created + for predicate checking is inserted after the corresponding + subprogram declaration, which is created at the point the + declaration is elaborated. + +2019-07-05 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Cleanup_Record): Use the underlying type when + checking for components with tasks. + +2019-07-05 Arnaud Charlet <charlet@adacore.com> + + * libgnarl/s-osinte__linux.ads: Link with -lrt before -lpthread. + +2019-07-05 Ed Schonberg <schonberg@adacore.com> + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Add explicit + range checks when the index type of the bit-packed array is an + enumeration type with a non-standard representation, + +2019-07-05 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Is_Control_Flow_Statement): Delay statements + contain an expression, which in turn may have side effects and + affect the infinite recursion. As a result, delay statements + should not be treated specially. + +2019-07-05 Arnaud Charlet <charlet@adacore.com> + + * libgnarl/s-linux.ads, libgnarl/s-linux__alpha.ads, + libgnarl/s-linux__android.ads, libgnarl/s-linux__hppa.ads, + libgnarl/s-linux__mips.ads, libgnarl/s-linux__riscv.ads, + libgnarl/s-linux__sparc.ads: Fix typos in comments. + +2019-07-05 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Check_Infinite_Recursion): Reimplemented. + (Enclosing_Declaration_Or_Statement, + Invoked_With_Different_Arguments, Is_Conditional_Statement, + Is_Control_Flow_Statement, Is_Immediately_Within_Body, + Is_Raise_Idiom, Is_Raise_Statement, Is_Sole_Statement, + Preceded_By_Control_Flow_Statement, + Within_Conditional_Statement): New routines. + +2019-07-05 Javier Miranda <miranda@adacore.com> + + * exp_ch4.adb (Expand_N_Type_Conversion): Do not apply an + accessibility check when the conversion is an access to + class-wide interface type and it is an actual parameter. + * exp_ch6.adb (Expand_Call_Helper): Add documentation on the + accessibility level of an anonymous allocator defining the value + of an access parameter. + * sem_util.ads, sem_util.adb (Dynamic_Accessibility_Level): Add + support for an anonymous allocator whose type is that of a + stand-alone object of an anonymous access to object type. + +2019-07-05 Piotr Trojanek <trojanek@adacore.com> + + * einfo.ads, sem_res.adb: Typo fixes in comments. + +2019-07-05 Bob Duff <duff@adacore.com> + + * exp_ch6.adb (Is_Build_In_Place_Function): Narrow the check for + Has_Foreign_Convention to the imported case only. If a + build-in-place function is exported, and called from Ada code, + build-in-place protocols should be used. + +2019-07-05 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Encloing_Subprogram): If Enclosing_Dynamic_Scope + is a loop, continue climbing the scope stack to find the + enclosing subprogram. + (Gather_Components): Handle properly a choice in a record + aggregate that is given by a subtype with a static predicate. + +2019-07-05 Javier Miranda <miranda@adacore.com> + + * debug.adb (-gnatd.K): Leave available this switch. + * contracts.adb (Build_And_Analyze_Contract_Only_Subprograms): + Remove. + * scil_ll.ads, scil_ll.adb (Contract_Only_Body_Flag, + Contract_Only_Body_Nodes, Get_Contract_Only_Body, + Is_Contract_Only_Body, Set_Contract_Only_Body): Remove. + +2019-07-05 Pierre-Marie de Rodat <derodat@adacore.com> + + * libgnat/a-strunb.ads: Import documentation from the RM + +2019-07-05 Pierre-Marie de Rodat <derodat@adacore.com> + + * libgnat/a-strfix.ads: Import documentation from the RM + +2019-07-05 Yannick Moy <moy@adacore.com> + + * adabkend.adb (Scan_Back_End_Switches): Accept -Og and -Ofast + switches. + +2019-07-05 Hristian Kirtchev <kirtchev@adacore.com> + + * ali.adb: Relocate types Invocation_Construct_Record, + Invocation_Relation_Record, and Invocation_Signature_Record to + the body of ALI. Relocate tables Invocation_Constructs, + Invocation_Relations, and Invocation_Signatures to the body of + ALI. Remove type Body_Placement_Codes. Add new types + Declaration_Placement_Codes, and + Invocation_Graph_Encoding_Codes. Update the literals of type + Invocation_Graph_Line_Codes. + (Add_Invocation_Construct): Update the parameter profile. Add an + invocation construct built from all attributes provided. + (Add_Invocation_Relation): Update the parameter profile. Add an + invocation relation built from all attributes provided. + (Body_Placement): New routine. + (Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind): + Removed. + (Code_To_Declaration_Placement_Kind, + Code_To_Invocation_Graph_Encoding_Kind, Column, + Declaration_Placement_Kind_To_Code, Extra, + For_Each_Invocation_Construct, For_Each_Invocation_Relation, + Invocation_Graph_Encoding, + Invocation_Graph_Encoding_Kind_To_Code, Invoker, Kind, Line, + Locations, Name): New routine. + (Scan_Invocation_Construct_Line): Reimplement the scanning + mechanism. + (Scan_Invocation_Graph_Attributes_Line): New routine. + (Scan_Invocation_Graph_Line): Use a case statement to dispatch. + (Scan_Invocation_Relation_Line): Reimplement the scanning + mechanism. + (Scope): New routine. + (Set_Invocation_Graph_Encoding, Signature, Spec_Placement, + Target): New routine. + * ali.ads: Add new type Invocation_Graph_Encoding_Kind. Add + component Invocation_Graph_Encoding to type Unit_Record. + Relocate various types and data structures to the body of ALI. + (Add_Invocation_Construct, Add_Invocation_Relation): Update the + parameter profile. + (Body_Placement): New routine. + (Body_Placement_Kind_To_Code, Code_To_Body_Placement_Kind): + Removed. + (Code_To_Declaration_Placement_Kind, + Code_To_Invocation_Graph_Encoding_Kind, Column, + Declaration_Placement_Kind_To_Code, Extra, + For_Each_Invocation_Construct, For_Each_Invocation_Relation, + Invocation_Graph_Encoding, + Invocation_Graph_Encoding_Kind_To_Code, Invoker, Kind, Line, + Locations, Name, Scope, Set_Invocation_Graph_Encoding, + Signature, Spec_Placement, Target): New routine. + * bindo.adb: Add with clause for Binde. Add with and use + clauses for Debug. Update the documentation. Add new switches. + (Find_Elaboration_Order): Dispatch to the proper elaboration + mechanism. + * bindo-augmentors.adb: + Remove with and use clauses for GNAT and GNAT.Sets. Remove + membership set VS. Update the parameter profiles of most + routines to use better parameter names. Update the + implementation of most routine to use the new parameter names. + Remove various redundant assertions. + * bindo-builders.adb: Use better names for instantiated data + structures. Update all references to these names. Update the + parameter profiles of most routines to use better parameter + names. Update the implementation of most routine to use the new + parameter names. + (Build_Library_Graph): Update the parameter profile. Update the + call to Create. + (Create_Vertex): Reimplemented. + (Declaration_Placement_Vertex): New routine. + * bindo-builders.ads (Build_Library_Graph): Update the parameter + profile and comment on usage. + * bindo-diagnostics.adb: Almost a new unit. + * bindo-diagnostics.ads: Add a use clause for + Bindo.Graphs.Invocation_Graphs. Remove package + Cycle_Diagnostics. + (Diagnose_Circularities): New routine. + * bindo-elaborators.adb: Remove the with and use clauses for + Binderr and GNAT.Sets. Remove the use clause for + Bindo.Diagnostics.Cycle_Diagnostics. Remove membership set VS. + Update the parameter profiles of most routines to use better + parameter names. Update the implementation of most routine to + use the new parameter names. (Elaborate_Units_Common): Update + the parameter profile. Pass an infication to the library graph + builder whether the dynamic model is in effect. + (Elaborate_Units_Dynamic, Elaborate_Units_Static): Use + Diagnose_Circularities to provide diagnostics. + (Update_Successor): Use routine In_Same_Component to determine + whether the predecessor and successor reside in different + components. + * bindo-graphs.adb: Add with and use clauses for Butil, Debug, + Output, and Bindo.Writers. Remove with and use clauses for + GNAT.Lists. Update the parameter profiles of most routines to + use better parameter names. Update the implementation of most + routine to use the new parameter names. Remove various + redundant assertions. Remove doubly linked list EL. Add new + type Precedence_Kind. + (Add_Cycle): New routine. + (Add_Vertex): Update the parameter profile. Update the creation + of vertex attributes. + (Add_Vertex_And_Complement, Body_Vertex, Column, + Complementary_Vertex, Copy_Cycle_Path, Cycle_Kind_Of): New + routines. + (Destroy_Invocation_Graph_Edge, Destroy_Library_Graph_Cycle, + Destroy_Library_Graph_Edge, Extra, File_Name, + Find_All_Cycles_Through_Vertex, Find_All_Cycles_With_Edge, + Find_Cycles, Find_First_Lower_Precedence_Cycle, + Get_LGC_Attributes, Has_Next, Hash_Library_Graph_Cycle, + Hash_Library_Graph_Cycle_Attributes, Highest_Precedence_Cycle, + Highest_Precedence_Edge, In_Same_Component, Insert_And_Sort, + Invocation_Edge_Count, Invocation_Graph_Encoding, + Is_Cycle_Initiating_Edge, Is_Cyclic_Edge, + Is_Cyclic_Elaborate_All_Edge, Is_Cyclic_Elaborate_Body_Edge, + Is_Cyclic_Elaborate_Edge, Is_Cyclic_Forced_Edge, + Is_Cyclic_Invocation_Edge, Is_Cyclic_With_Edge, + Is_Dynamically_Elaborated, Is_Elaborate_All_Edge, + Is_Elaborate_Body_Edge, Is_Elaborate_Edge: New routines. + (Is_Existing_Predecessor_Successor_Relation): Removed. + (Is_Forced_Edge, Is_Invocation_Edge, Is_Recorded_Cycle, + Is_Recorded_Edge, Is_With_Edge, Iterate_Edges_Of_Cycle, Kind, + Length): New routine. + (Lib_Vertex): Removed. + (Line, Links_Vertices_In_Same_Component, + Maximum_Invocation_Edge_Count, Next, Normalize_And_Add_Cycle, + Normalize_Cycle_Path, Number_Of_Cycles, Path, Precedence, + Remove_Vertex_And_Complement, Sequence_Next_Cycle): New routines. + (Sequence_Next_IGE_Id): Renamed to Sequence_Next_Edge. + (Sequence_Next_IGV_Id): Renamed to Sequence_Next_Vertex. + (Sequence_Next_LGE_Id): Renamed to Sequence_Next_Edge. + (Sequence_Next_LGV_Id): Renamed to Sequence_Next_Vertex. + (Set_Is_Existing_Predecessor_Successor_Relation): Removed. + (Set_Is_Recorded_Cycle, Set_Is_Recorded_Edge, + Set_LGC_Attributes, Spec_Vertex, Trace_Cycle, Trace_Edge, + Trace_Eol, Trace_Vertex): New routines. + * bindo-graphs.ads: Add with and use clauses for Types and + GNAT.Lists. Update the parameter profiles of most routines to + use better parameter names. Update the implementation of most + routine to use the new parameter names. Add the new + instantiated data structures IGE_Lists, IGV_Sets, LGC_Lists, + LGE_Lists, LGE_Sets, LGV_Sets, and RC_Sets. Add new type + Library_Graph_Cycle_Id along with an empty and initial value. + Remove component Lib_Vertex and add new components Body_Vertex + and Spec_Vertex to type Invocation_Graph_Vertex_Attributes. Add + new type Library_Graph_Cycle_Kind. Add new iterators + All_Cycle_Iterator and Edges_Of_Cycle_Iterator. Add new type + Library_Graph_Cycle_Attributes. Add new components + Cycle_Attributes, Cycles, and Dynamically_Elaborated to type + Library_Graph_Attributes. + (Body_Vertex, Column, Destroy_Invocation_Graph_Edge, + Destroy_Library_Graph_Cycle_Attributes, + Destroy_Library_Graph_Edge, Extra, File_Name, Find_Cycles, + Has_Elaborate_All_Cycle, Has_Next, Hash_Library_Graph_Cycle, + Hash_Library_Graph_Cycle_Attributes, Highest_Precedence_Cycle, + In_Same_Component, Invocation_Edge_Count, + Invocation_Graph_Encoding, Is_Dynamically_Elaborated, + Is_Elaborate_All_Edge, Is_Elaborate_Body_Edge, + Is_Elaborate_Edge, Is_Forced_Edge, Is_Invocation_Edge, + Is_With_Edge, Iterate_All_Cycles, Iterate_Edges_Of_Cycle, Kind): + New routines. + (Length, Lib_Vertex, (Line, Next, Number_Of_Cycles, Present, + Same_Library_Graph_Cycle_Attributes, Spec_Vertex): New routines. + * bindo-units.adb (File_Name, Invocation_Graph_Encoding): New + routines. + * bindo-units.ads: Add new instantiated data structure + Unit_Sets. + (File_Name, Invocation_Graph_Encoding): New routine. + * bindo-validators.adb: Remove with and use clauses for GNAT and + GNAT.Sets. Remove membership set US. Update the parameter + profiles of most routines to use better parameter names. Update + the implementation of most routine to use the new parameter + names. + (Validate_Cycle, Validate_Cycle_Path, Validate_Cycles, + Validate_Invocation_Graph_Vertex): Remove the validation of + component Lib_Vertex. Add the validation of components + Body_Vertex and Spec_Vertex. + (Write_Error): New routine. + * bindo-validators.ads (Validate_Cycles): New routine. + * bindo-writers.adb: Update the parameter profiles of most + routines to use better parameter names. Update the + implementation of most routine to use the new parameter names. + (Write_Cycle, Write_Cyclic_Edge, Write_Cycles): New routines. + (Write_Invocation_Graph_Vertex): Remove the output of component + Lib_Vertex. Add the output of components Body_Vertex and + Spec_Vertex. + * bindo-writers.ads (Write_Cycles): New routine. + * debug.adb: Use binder switches -d_C and -d_P, add + documentation on their usage. + * gnatbind.adb: Remove with and use clauses for Binde. Delegate + the choice of elaboration mechanism to Bindo. + * lib-writ.adb (Column, Extra, Invoker, Kind, Line, Locations, + Name, Placement, Scope, Signature, Target): Removed. + (Write_Invocation_Graph): Moved at the top level. + (Write_Invocation_Graph_Attributes): New routine. + (Write_Invocation_Relation, Write_Invocation_Signature): Moved + at the top level. + * lib-writ.ads: Add a documentation section on invocation graph + attributes. + * sem_elab.adb (Body_Placement_Of): New routine. + (Declare_Invocation_Construct): Update the call to + Add_Invocation_Construct. + (Declaration_Placement_Of_Node): New routine. + (Get_Invocation_Attributes): Correct the retrieval of the + enclosing subprogram where the postcondition procedure lives. + (Placement_Of, Placement_Of_Node): Removed. + (Record_Invocation_Graph): Record the encoding format used. + (Record_Invocation_Graph_Encoding): New routine. + (Record_Invocation_Relation): Update the call to + Add_Invocation_Relation. + (Spec_Placement_Of): Removed. + * libgnat/g-lists.ads, libgnat/g-lists.adb (Equal): New routine. + +2019-07-05 Ed Schonberg <schonberg@adacore.com> + + * checks.adb (Apply_Predicate_Check): Except within the + subprogram body that defines the formal, do not apply predicate + check on a formal IN parameter: such a check is redundant and + its expansion can lead to out-of-scope references when it is + originates in a function call in a precondition, + +2019-07-05 Yannick Moy <moy@adacore.com> + + * sem_res.adb (Resolve_Call): Cannot inline in quantified + expressions. + * sem_util.adb, sem_util.ads (In_Quantified_Expression): New + function. + +2019-07-05 Bob Duff <duff@adacore.com> + + * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst: + Fix typo. + * gnat_rm.texi: Regenerate. + +2019-07-05 Bob Duff <duff@adacore.com> + + * exp_attr.adb (Input): Take the No_Stream_Optimizations + restriction into account. + +2019-07-05 Claire Dross <dross@adacore.com> + + * libgnat/a-cofove.ads, libgnat/a-cofove.adb: Definite formal + vectors are now always bounded so that they do not need to be + limited anymore. + +2019-07-05 Dmitriy Anisimkov <anisimko@adacore.com> + + * libgnat/g-traceb.ads, libgnat/g-traceb.adb (Call_Chain): New + function. + +2019-07-04 James Clarke <jrtc27@debian.org> + + * libgnarl/s-osinte__kfreebsd-gnu.ads (clockid_t): Make type + definition public. + (CLOCK_REALTIME): Make value public. + +2019-07-04 Javier Miranda <miranda@adacore.com> + + * exp_tss.adb (Init_Proc): Adding missing support for access to + subprograms and access to protected subprograms of non-default + C++ constructors. + +2019-07-04 Eric Botcazou <ebotcazou@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Use proper interface to + set the validity settings in CodePeer mode. + * par-load.adb (Load): Remove all code dealing with validity + settings. + * validsw.ads (Validity_Check_Copies): Alphabetize. + * validsw.adb (Reset_Validity_Check_Options): Set all options to + off. + (Save_Validity_Check_Options): Save all options. + +2019-07-04 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch3.adb, exp_ch4.adb, exp_ch4.ads, exp_ch5.adb, + exp_ch7.adb, exp_ch9.adb, exp_ch11.adb, exp_unst.adb, + rtsfind.ads, sem_attr.adb, sem_ch10.adb, sem_ch12.adb, + sem_ch13.adb, sem_dim.adb, sem_disp.adb, xref_lib.adb: Minor + reformatting. + +2019-07-04 Joffrey Huguet <huguet@adacore.com> + + * libgnarl/a-taside.ads: Add assertion policy to ignore + preconditions. + (Abort_Task, Is_Terminated, Is_Callable): Add preconditions. + +2019-07-04 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Fix + capitalization and parenthesis glitches. + * gnat_rm.texi: Regenerate. + +2019-07-04 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Remove_Context_Clauses): Handle properly the + removal of a limited_with_clause which appears in the library + unit oF the main unit, when some other unit in the context has a + regular with_clause on the same unit, to prevent spurious + visibility errors in the subsequent analysis of pending instance + bodies. + +2019-07-04 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_elab.adb: Add new type Elaboration_Phase_Status along with + a global to keep track of the elaboration phase status. + Initialize all internal data structures to Nil for services + Elaborated_Units, Internal_Representation, and Scenario_Storage. + (Build_Call_Marker): Do not create a call marker when the + elaboration phase is not active. + (Build_Variable_Reference_Marker): Do not create a call marker + when the elaboration phase is not active. + (Check_Elaboration_Scenarios): Destroy all internal structures + when the elaboration phase does not have to run. Do not execute + when the elaboration phase is not active. + (Elaboration_Phase_Active): New routine. + (Finalize_All_Data_Structures): New routine. + (Initialize): Initialize all internal data structures and signal + that the elaboration phase has started. + (Initialize_All_Data_Structures): New routine. + (Initialize_Elaborated_Units): Initialize all internal data + structures. + (Initialize_Internal_Representation): Initialize all internal + data structures. + (Initialize_Scenario_Storage): Initialize all internal data + structures. + (Kill_Elaboration_Scenario): Do not execute when the elaboration + phase is not active. + (Set_Elaboration_Phase): New routine. + (Update_Elaboration_Scenario): Do not execute when the + elaboration phase is not active. + +2019-07-04 Gary Dismukes <dismukes@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): The special + treatment of calling Mask_Unfrozen_Types must also be done in + the case of an Ignored_Ghost_Entity, because Expander_Active is + False in that case. + +2019-07-04 Yannick Moy <moy@adacore.com> + + * sem_prag.adb (Check_Library_Level_Entity): Update for new rule + on SPARK_Mode. + +2019-07-04 Justin Squirek <squirek@adacore.com> + + * sem_disp.adb (Check_Controlling_Formals): Obtain the full view + before type comparison. + +2019-07-04 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.ads, exp_ch4.adb (Build_Eq_Call): New visible + subprogram, extracted from Expand_Composite_Equality, to handle + properly the composition of equality for variant record types. + * exp_ch3.adb (MAke_Eq_If): Use Build_Eq_Call for each + component, to handle properly the case of a component with a + user-defined equality. Revert to predefined equality if the + user-defined operation is abstract, to maintain compatibility + with older versions, + +2019-07-04 Justin Squirek <squirek@adacore.com> + + * exp_ch3.adb (Build_Initialization_Call): Fixup + *_skip_null_excluding_check argument to handle new default. + (Init_Formals): Make *_skip_null_excluding_check formal default + to False + * exp_ch4.adb (Expand_N_Allocator): Add comment to note heavy + code duplication + +2019-07-04 Bob Duff <duff@adacore.com> + + * sem_ch3.adb (Access_Definition): Do not create a master unless + Tasking_Allowed. Otherwise, this fails on restricted runtimes. + +2019-07-04 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_util.adb (Propagate_DIC_Attributes): Do not propagate the + Default_Initial_Condition attributes to an incomplete type. + +2019-07-04 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Check_Array_Type): An array type attribute such + as 'First can be applied to an unconstrained array tyope when + the attribute reference appears within an aspect specification + and the prefix is a current instance, given that the prefix of + the attribute will become a formal of the subprogram that + implements the aspect (typically a predicate check). + +2019-07-04 Piotr Trojanek <trojanek@adacore.com> + + * sem_util.adb (Yields_Synchronized_Object): Fix typos in + comments. + +2019-07-04 Yannick Moy <moy@adacore.com> + + * sem_util.adb (Yields_Synchronized_Object): Adapt to new SPARK + rule. + +2019-07-04 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Check_Statement): Only check permission of + object in extended return when it is of a deep type. + +2019-07-04 Justin Squirek <squirek@adacore.com> + + * sem_ch12.adb (Perform_Appropriate_Analysis): Added for + selecting which type of analysis based on wheither the + instantiation is a generic at the library-level. In which case + expansion during analysis. + (Preanalyze_Actuals): Modify calls to Analyze to use the new + routine. + +2019-07-04 Ed Schonberg <schonberg@adacore.com> + + * exp_unst.adb: Handle conditional expressions. + +2019-07-04 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Check_Package_Spec, Check_Package_Body): Only + analyze parts of the code marked in SPARK. + +2019-07-04 Hristian Kirtchev <kirtchev@adacore.com> + + * erroutc.adb, exp_aggr.adb, inline.adb, opt.adb, sem_ch3.adb: + Minor reformatting. + +2019-07-04 Yannick Moy <moy@adacore.com> + + * sem_spark.adb (Explanation, Get_Expl): New functions to get + the explanation for a permission mismatch. + (Perm_Error, Perm_Mismatch, Perm_Error_Loop_Exit): Take + explanation into account for issuing a more precise error + message. + (Set_Perm_Prefixes, Set_Perm_Extensions, + Set_Perm_Extensions_Move): Pass suitable argument for the + explanation node. + +2019-07-04 Arnaud Charlet <charlet@adacore.com> + + * exp_aggr.adb (In_Place_Assign_OK): Moved to top level and add + support for record aggregates. + (Component_Check): Use Is_CCG_Supported_Aggregate instead of a + similar local predicate. + (Convert_To_Assignments): Take advantage of In_Place_Assign_OK + predicate when possible. + (Is_CCG_Supported_Aggregate): Return False for records with + representation clauses and fix the logic for dealing with nested + aggregates. + +2019-07-04 Piotr Trojanek <trojanek@adacore.com> + + * opt.adb (Set_Config_Switches): Keep assertions policy as + enabled when analysing internal units in GNATprove mode. + +2019-07-04 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb (Expand_Short_Circuit_Operator): Strip + N_Variable_Reference_Marker when checking for the presence of + actions. + +2019-07-04 Arnaud Charlet <charlet@adacore.com> + + * exp_aggr.adb (Check_Component): Take into account type + conversions. + +2019-07-04 Dmitriy Anisimkov <anisimko@adacore.com> + + * doc/gnat_ugn/platform_specific_information.rst: Document + Windows socket timeout particularity. + * gnat_ugn.texi: Regenerate. + * gsocket.h: Include versionhelpers.h. + * socket.c (__gnat_minus_500ms): New function. + * libgnat/g-sothco.ads (Minus_500ms_Windows_Timeout): New + imported function. + * libgnat/g-socket.adb (Set_Socket_Option): Refactor to remove + 500ms from the requested timeout only on old Windows version. + +2019-07-04 Thomas Quinot <quinot@adacore.com> + + * get_scos.adb: Remove bogus, dead code. + +2019-07-04 Ed Schonberg <schonberg@adacore.com> + + * sem_dim.adb (Analyze_Dimension_Array_Aggregate): If the + component is an entity name, its dimensions are those of its + type. + 2019-07-03 Bob Duff <duff@adacore.com> * doc/gnat_ugn/gnat_utility_programs.rst: Document new flags in diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 916ae3e..6528df8 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -387,6 +387,7 @@ GNATRTL_NONTASKING_OBJS= \ g-arrspl$(objext) \ g-awk$(objext) \ g-binenv$(objext) \ + g-brapre$(objext) \ g-bubsor$(objext) \ g-busora$(objext) \ g-busorg$(objext) \ @@ -867,7 +868,7 @@ GCC_SPEC_FILES= # If what's left is null then it's a match. # PowerPC and e500v2 VxWorks -ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7 vxworks7spe,$(target_cpu) $(target_vendor) $(target_os))),) +ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7% vxworks7spe,$(target_cpu) $(target_vendor) $(target_os))),) ifeq ($(strip $(filter-out e500%, $(target_alias))),) ARCH_STR=e500 @@ -1118,7 +1119,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae,$(target_cpu) $(target_vendor) $(ta endif # x86/x86_64 VxWorks -ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7,$(target_cpu) $(target_vendor) $(target_os))),) +ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7%,$(target_cpu) $(target_vendor) $(target_os))),) EH_MECHANISM=-gcc @@ -1521,7 +1522,6 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),) s-intman.adb<libgnarl/s-intman__posix.adb \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ $(TRASYM_DWARF_UNIX_PAIRS) \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ s-tsmona.adb<libgnat/s-tsmona__linux.adb \ a-exetim.adb<libgnarl/a-exetim__posix.adb \ a-exetim.ads<libgnarl/a-exetim__default.ads \ @@ -2046,7 +2046,6 @@ ifeq ($(strip $(filter-out mips% linux%,$(target_cpu) $(target_os))),) s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \ s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ system.ads<libgnat/system-linux-mips.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb @@ -2072,7 +2071,6 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),) s-linux.ads<libgnarl/s-linux.ads \ s-osinte.adb<libgnarl/s-osinte__posix.adb \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ $(TRASYM_DWARF_UNIX_PAIRS) \ s-tsmona.adb<libgnat/s-tsmona__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ @@ -2151,7 +2149,6 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),) s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ s-taspri.ads<libgnarl/s-taspri__posix.ads \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ $(ATOMICS_BUILTINS_TARGET_PAIRS) \ system.ads<libgnat/system-linux-arm.ads @@ -2296,7 +2293,6 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),) s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ $(TRASYM_DWARF_UNIX_PAIRS) \ s-tsmona.adb<libgnat/s-tsmona__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ @@ -2393,7 +2389,6 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),) s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ s-taspri.ads<libgnarl/s-taspri__posix.ads \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ $(TRASYM_DWARF_UNIX_PAIRS) \ s-tsmona.adb<libgnat/s-tsmona__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ @@ -2435,7 +2430,6 @@ ifeq ($(strip $(filter-out %x32 linux%,$(target_cpu) $(target_os))),) s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \ s-taspri.ads<libgnarl/s-taspri__posix.ads \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ $(ATOMICS_TARGET_PAIRS) \ $(X86_64_TARGET_PAIRS) \ system.ads<libgnat/system-linux-x86.ads @@ -2466,7 +2460,6 @@ ifeq ($(strip $(filter-out riscv% linux%,$(target_cpu) $(target_os))),) s-tasinf.adb<libgnarl/s-tasinf__linux.adb \ s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \ s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \ - g-sercom.adb<libgnat/g-sercom__linux.adb \ system.ads<libgnat/system-linux-riscv.ads TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb @@ -2594,6 +2587,11 @@ ifeq ($(EH_MECHANISM),-arm) EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o endif +ifeq ($(strip $(filter-out linux%,$(target_os))),) + LIBGNAT_TARGET_PAIRS += \ + g-sercom.adb<libgnat/g-sercom__linux.adb +endif + # LIBGNAT_SRCS is the list of all C files (including headers) of the runtime # library. LIBGNAT_OBJS is the list of object files for libgnat. # thread.c is special as put into GNATRTL_TASKING_OBJS @@ -2612,7 +2610,7 @@ LIBGNAT_OBJS = adadecode.o adaint.o argv.o aux-io.o \ LIBGNAT_SRCS = $(patsubst %.o,%.c,$(LIBGNAT_OBJS)) \ adadecode.h adaint.h env.h gsocket.h raise.h standard.ads.h \ - tb-gcc.c libgnarl/thread.c $(EXTRA_LIBGNAT_SRCS) + tb-gcc.c runtime.h libgnarl/thread.c $(EXTRA_LIBGNAT_SRCS) # memtrack.o is special as not put into libgnat. GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \ @@ -2689,9 +2687,15 @@ setup-rts: force $(LN_S) $(GNAT_SRC)/$(word 2,$(subst <, ,$(PAIR))) \ $(RTSDIR)/$(word 1,$(subst <, ,$(PAIR)));) -# Special flags +# Special flags. It is recommended not to change the compilation flags +# without a careful analysis of the consequences because (part of) the +# runtime implements low-level support that is outside of the semantics +# of the language and therefore needs to be treated differently from the +# other units. For example, the part of the runtime implementing the +# propagation of exceptions cannot itself be compiled with checks that +# may give rise to exceptions, e.g. stack overflow checks. -# force no sibling call optimization on s-traceb.o so the number of stack +# Force no sibling call optimization on s-traceb.o so the number of stack # frames to be skipped when computing a call chain is not modified by # optimization. We don't want inlining, either. @@ -2700,14 +2704,14 @@ s-traceb.o : s-traceb.adb s-traceb.ads $(NO_INLINE_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) $< \ $(OUTPUT_OPTION) -# compile s-tasdeb.o without optimization and with debug info so that it is +# Compile s-tasdeb.o without optimization and with debug info so that it is # always possible to set conditional breakpoints on tasks. s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) -# force no function reordering on a-except.o because of the exclusion bounds +# Force no function reordering on a-except.o because of the exclusion bounds # mechanism (see the source file for more detailed information). # force debugging information on a-except.o so that it is always # possible to set conditional breakpoints on exceptions. @@ -2718,7 +2722,7 @@ a-except.o : a-except.adb a-except.ads $(NO_INLINE_ADAFLAGS) $(NO_REORDER_ADAFLAGS) -O1 $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) -# compile s-excdeb.o without optimization and with debug info to let the +# Compile s-excdeb.o without optimization and with debug info to let the # debugger set breakpoints and inspect subprogram parameters on exception # related events. @@ -2726,21 +2730,21 @@ s-excdeb.o : s-excdeb.adb s-excdeb.ads s-except.ads $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ $(ADA_INCLUDES) $< $(OUTPUT_OPTION) -# force debugging information on s-assert.o so that it is always +# Force debugging information on s-assert.o so that it is always # possible to set breakpoint on assert failures. s-assert.o : s-assert.adb s-assert.ads $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) -# force debugging information on a-tags.o so that the debugger can find +# Force debugging information on a-tags.o so that the debugger can find # the description of Ada.Tags.Type_Specific_Data. a-tags.o : a-tags.adb a-tags.ads $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) -# force no sibling call optimization on s-memory.o to avoid turning the +# Force no sibling call optimization on s-memory.o to avoid turning the # tail recursion in Alloc into a loop that confuses branch prediction. s-memory.o : s-memory.adb s-memory.ads diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb index c42f3bd..3e1b14d 100644 --- a/gcc/ada/adabkend.adb +++ b/gcc/ada/adabkend.adb @@ -117,9 +117,11 @@ package body Adabkend is -- Set optimization indicators appropriately. In gcc-based GNAT this -- is picked up from imported variables set by the gcc driver, but - -- for compilers with non-gcc back ends we do it here to allow use - -- of these switches by the front end. Allowed optimization switches - -- are -Os (optimize for size), -O[0123], and -O (same as -O1). + -- for compilers with non-gcc back ends we do it here to allow use of + -- these switches by the front end. Allowed optimization switches are + -- -Os (optimize for size), -O[0123], -O (same as -O1), -Ofast + -- (disregard strict standards compliance), and -Og (optimize + -- debugging experience). elsif Switch_Chars (First) = 'O' then if First = Last then @@ -134,10 +136,21 @@ package body Adabkend is Optimization_Level := Character'Pos (Switch_Chars (Last)) - Character'Pos ('0'); + -- Switch -Og is between -O0 and -O1 in GCC. Consider it like + -- -O0 for other back ends. + + elsif Switch_Chars (Last) = 'g' then + Optimization_Level := 0; + else Fail ("invalid switch: " & Switch_Chars); end if; + -- Switch -Ofast enables -O3 + + elsif Switch_Chars (First + 1 .. Last) = "fast" then + Optimization_Level := 3; + else Fail ("invalid switch: " & Switch_Chars); end if; @@ -169,7 +182,7 @@ package body Adabkend is return; - -- Special check, the back end switch -fno-inline also sets the + -- Special check, the back-end switch -fno-inline also sets the -- front end flags to entirely inhibit all inlining. So we store it -- and set the appropriate flags. @@ -206,7 +219,7 @@ package body Adabkend is end case; end if; - -- Ignore all other back end switches + -- Ignore all other back-end switches elsif Is_Back_End_Switch (Switch_Chars) then null; diff --git a/gcc/ada/adadecode.c b/gcc/ada/adadecode.c index a574f3c..f87d421 100644 --- a/gcc/ada/adadecode.c +++ b/gcc/ada/adadecode.c @@ -29,15 +29,7 @@ * * ****************************************************************************/ - -#if defined(IN_RTS) -#include "tconfig.h" -#include "tsystem.h" -#elif defined(IN_GCC) -#include "config.h" -#include "system.h" -#endif - +#include "runtime.h" #include <string.h> #include <stdio.h> #include <ctype.h> diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 4a75b59..fe8d955 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -88,8 +88,26 @@ #endif #ifdef IN_RTS + +#ifdef STANDALONE +#include <errno.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <unistd.h> +#include <stdlib.h> +#include <string.h> + +/* for CPU_SET/CPU_ZERO */ +#define _GNU_SOURCE +#define __USE_GNU + +#include "runtime.h" + +#else #include "tconfig.h" #include "tsystem.h" +#endif + #include <sys/stat.h> #include <fcntl.h> #include <time.h> diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 2ae8766..311e240 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -51,7 +51,7 @@ extern "C" { determine at compile time what support the system offers for large files. For now we just list the platforms we have manually tested. */ -#if defined (__GLIBC__) || defined (__sun__) || defined (__QNX__) +#if (defined (__GLIBC__) && !defined(STANDALONE)) || defined (__sun__) || defined (__QNX__) #define GNAT_FOPEN fopen64 #define GNAT_OPEN open64 #define GNAT_STAT stat64 diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 978fb3d..feea73f 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -39,10 +39,115 @@ package body ALI is use ASCII; -- Make control characters visible + ----------- + -- Types -- + ----------- + + -- The following type represents an invocation construct + + type Invocation_Construct_Record is record + Body_Placement : Declaration_Placement_Kind := No_Declaration_Placement; + -- The location of the invocation construct's body with respect to the + -- unit where it is declared. + + Kind : Invocation_Construct_Kind := Regular_Construct; + -- The nature of the invocation construct + + Signature : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature that uniquely identifies the invocation + -- construct in the ALI space. + + Spec_Placement : Declaration_Placement_Kind := No_Declaration_Placement; + -- The location of the invocation construct's spec with respect to the + -- unit where it is declared. + end record; + + -- The following type represents an invocation relation. It associates an + -- invoker that activates/calls/instantiates with a target. + + type Invocation_Relation_Record is record + Extra : Name_Id := No_Name; + -- The name of an additional entity used in error diagnostics + + Invoker : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature that uniquely identifies the invoker within + -- the ALI space. + + Kind : Invocation_Kind := No_Invocation; + -- The nature of the invocation + + Target : Invocation_Signature_Id := No_Invocation_Signature; + -- The invocation signature that uniquely identifies the target within + -- the ALI space. + end record; + + -- The following type represents an invocation signature. Its purpose is + -- to uniquely identify an invocation construct within the ALI space. The + -- signature comprises several pieces, some of which are used in error + -- diagnostics by the binder. Identification issues are resolved as + -- follows: + -- + -- * The Column, Line, and Locations attributes together differentiate + -- between homonyms. In most cases, the Column and Line are sufficient + -- except when generic instantiations are involved. Together, the three + -- attributes offer a sequence of column-line pairs that eventually + -- reflect the location within the generic template. + -- + -- * The Name attribute differentiates between invocation constructs at + -- the scope level. Since it is illegal for two entities with the same + -- name to coexist in the same scope, the Name attribute is sufficient + -- to distinguish them. Overloaded entities are already handled by the + -- Column, Line, and Locations attributes. + -- + -- * The Scope attribute differentiates between invocation constructs at + -- various levels of nesting. + + type Invocation_Signature_Record is record + Column : Nat := 0; + -- The column number where the invocation construct is declared + + Line : Nat := 0; + -- The line number where the invocation construct is declared + + Locations : Name_Id := No_Name; + -- Sequence of column and line numbers within nested instantiations + + Name : Name_Id := No_Name; + -- The name of the invocation construct + + Scope : Name_Id := No_Name; + -- The qualified name of the scope where the invocation construct is + -- declared. + end record; + --------------------- -- Data structures -- --------------------- + package Invocation_Constructs is new Table.Table + (Table_Index_Type => Invocation_Construct_Id, + Table_Component_Type => Invocation_Construct_Record, + Table_Low_Bound => First_Invocation_Construct, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Constructs"); + + package Invocation_Relations is new Table.Table + (Table_Index_Type => Invocation_Relation_Id, + Table_Component_Type => Invocation_Relation_Record, + Table_Low_Bound => First_Invocation_Relation, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Relation"); + + package Invocation_Signatures is new Table.Table + (Table_Index_Type => Invocation_Signature_Id, + Table_Component_Type => Invocation_Signature_Record, + Table_Low_Bound => First_Invocation_Signature, + Table_Initial => 2500, + Table_Increment => 200, + Table_Name => "Invocation_Signatures"); + procedure Destroy (IS_Id : in out Invocation_Signature_Id); -- Destroy an invocation signature with id IS_Id @@ -68,14 +173,19 @@ package body ALI is Sig_To_Sig_Map : constant Sig_Map.Dynamic_Hash_Table := Sig_Map.Create (500); - -- The folowing table maps body placement kinds to character codes for - -- invocation construct encoding in ALI files. + -- The folowing table maps declaration placement kinds to character codes + -- for invocation construct encoding in ALI files. + + Declaration_Placement_Codes : + constant array (Declaration_Placement_Kind) of Character := + (In_Body => 'b', + In_Spec => 's', + No_Declaration_Placement => 'Z'); - Body_Placement_Codes : - constant array (Body_Placement_Kind) of Character := - (In_Body => 'b', - In_Spec => 's', - No_Body_Placement => 'Z'); + Compile_Time_Invocation_Graph_Encoding : Invocation_Graph_Encoding_Kind := + No_Encoding; + -- The invocation-graph encoding format as specified at compile time. Do + -- not manipulate this value directly. -- The following table maps invocation kinds to character codes for -- invocation relation encoding in ALI files. @@ -112,13 +222,23 @@ package body ALI is Elaborate_Spec_Procedure => 's', Regular_Construct => 'Z'); - -- The following table maps invocation graph line kinds to character codes + -- The following table maps invocation-graph encoding kinds to character + -- codes for invocation-graph encoding in ALI files. + + Invocation_Graph_Encoding_Codes : + constant array (Invocation_Graph_Encoding_Kind) of Character := + (Full_Path_Encoding => 'f', + Endpoints_Encoding => 'e', + No_Encoding => 'Z'); + + -- The following table maps invocation-graph line kinds to character codes -- used in ALI files. Invocation_Graph_Line_Codes : constant array (Invocation_Graph_Line_Kind) of Character := - (Invocation_Construct_Line => 'c', - Invocation_Relation_Line => 'r'); + (Invocation_Construct_Line => 'c', + Invocation_Graph_Attributes_Line => 'a', + Invocation_Relation_Line => 'r'); -- The following variable records which characters currently are used as -- line type markers in the ALI file. This is used in Scan_ALI to detect @@ -153,18 +273,22 @@ package body ALI is ------------------------------ procedure Add_Invocation_Construct - (IC_Rec : Invocation_Construct_Record; - Update_Units : Boolean := True) + (Body_Placement : Declaration_Placement_Kind; + Kind : Invocation_Construct_Kind; + Signature : Invocation_Signature_Id; + Spec_Placement : Declaration_Placement_Kind; + Update_Units : Boolean := True) is - IC_Id : Invocation_Construct_Id; - begin - pragma Assert (Present (IC_Rec.Signature)); + pragma Assert (Present (Signature)); -- Create a invocation construct from the scanned attributes - Invocation_Constructs.Append (IC_Rec); - IC_Id := Invocation_Constructs.Last; + Invocation_Constructs.Append + ((Body_Placement => Body_Placement, + Kind => Kind, + Signature => Signature, + Spec_Placement => Spec_Placement)); -- Update the invocation construct counter of the current unit only when -- requested by the caller. @@ -174,7 +298,7 @@ package body ALI is Curr_Unit : Unit_Record renames Units.Table (Units.Last); begin - Curr_Unit.Last_Invocation_Construct := IC_Id; + Curr_Unit.Last_Invocation_Construct := Invocation_Constructs.Last; end; end if; end Add_Invocation_Construct; @@ -184,20 +308,24 @@ package body ALI is ----------------------------- procedure Add_Invocation_Relation - (IR_Rec : Invocation_Relation_Record; + (Extra : Name_Id; + Invoker : Invocation_Signature_Id; + Kind : Invocation_Kind; + Target : Invocation_Signature_Id; Update_Units : Boolean := True) is - IR_Id : Invocation_Relation_Id; - begin - pragma Assert (Present (IR_Rec.Invoker)); - pragma Assert (Present (IR_Rec.Target)); - pragma Assert (IR_Rec.Kind /= No_Invocation); + pragma Assert (Present (Invoker)); + pragma Assert (Kind /= No_Invocation); + pragma Assert (Present (Target)); -- Create an invocation relation from the scanned attributes - Invocation_Relations.Append (IR_Rec); - IR_Id := Invocation_Relations.Last; + Invocation_Relations.Append + ((Extra => Extra, + Invoker => Invoker, + Kind => Kind, + Target => Target)); -- Update the invocation relation counter of the current unit only when -- requested by the caller. @@ -207,41 +335,42 @@ package body ALI is Curr_Unit : Unit_Record renames Units.Table (Units.Last); begin - Curr_Unit.Last_Invocation_Relation := IR_Id; + Curr_Unit.Last_Invocation_Relation := Invocation_Relations.Last; end; end if; end Add_Invocation_Relation; - --------------------------------- - -- Body_Placement_Kind_To_Code -- - --------------------------------- + -------------------- + -- Body_Placement -- + -------------------- - function Body_Placement_Kind_To_Code - (Kind : Body_Placement_Kind) return Character + function Body_Placement + (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind is begin - return Body_Placement_Codes (Kind); - end Body_Placement_Kind_To_Code; + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Body_Placement; + end Body_Placement; - --------------------------------- - -- Code_To_Body_Placement_Kind -- - --------------------------------- + ---------------------------------------- + -- Code_To_Declaration_Placement_Kind -- + ---------------------------------------- - function Code_To_Body_Placement_Kind - (Code : Character) return Body_Placement_Kind + function Code_To_Declaration_Placement_Kind + (Code : Character) return Declaration_Placement_Kind is begin - -- Determine which body placement kind corresponds to the character code - -- by traversing the contents of the mapping table. + -- Determine which placement kind corresponds to the character code by + -- traversing the contents of the mapping table. - for Kind in Body_Placement_Kind loop - if Body_Placement_Codes (Kind) = Code then + for Kind in Declaration_Placement_Kind loop + if Declaration_Placement_Codes (Kind) = Code then return Kind; end if; end loop; raise Program_Error; - end Code_To_Body_Placement_Kind; + end Code_To_Declaration_Placement_Kind; --------------------------------------- -- Code_To_Invocation_Construct_Kind -- @@ -263,6 +392,26 @@ package body ALI is raise Program_Error; end Code_To_Invocation_Construct_Kind; + -------------------------------------------- + -- Code_To_Invocation_Graph_Encoding_Kind -- + -------------------------------------------- + + function Code_To_Invocation_Graph_Encoding_Kind + (Code : Character) return Invocation_Graph_Encoding_Kind + is + begin + -- Determine which invocation-graph encoding kind matches the character + -- code by traversing the contents of the mapping table. + + for Kind in Invocation_Graph_Encoding_Kind loop + if Invocation_Graph_Encoding_Codes (Kind) = Code then + return Kind; + end if; + end loop; + + raise Program_Error; + end Code_To_Invocation_Graph_Encoding_Kind; + ----------------------------- -- Code_To_Invocation_Kind -- ----------------------------- @@ -291,7 +440,7 @@ package body ALI is (Code : Character) return Invocation_Graph_Line_Kind is begin - -- Determine which invocation graph line kind matches the character + -- Determine which invocation-graph line kind matches the character -- code by traversing the contents of the mapping table. for Kind in Invocation_Graph_Line_Kind loop @@ -303,6 +452,27 @@ package body ALI is raise Program_Error; end Code_To_Invocation_Graph_Line_Kind; + ------------ + -- Column -- + ------------ + + function Column (IS_Id : Invocation_Signature_Id) return Nat is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Column; + end Column; + + ---------------------------------------- + -- Declaration_Placement_Kind_To_Code -- + ---------------------------------------- + + function Declaration_Placement_Kind_To_Code + (Kind : Declaration_Placement_Kind) return Character + is + begin + return Declaration_Placement_Codes (Kind); + end Declaration_Placement_Kind_To_Code; + ------------- -- Destroy -- ------------- @@ -313,6 +483,92 @@ package body ALI is null; end Destroy; + ----------- + -- Extra -- + ----------- + + function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Extra; + end Extra; + + ----------------------------------- + -- For_Each_Invocation_Construct -- + ----------------------------------- + + procedure For_Each_Invocation_Construct + (Processor : Invocation_Construct_Processor_Ptr) + is + begin + pragma Assert (Processor /= null); + + for IC_Id in Invocation_Constructs.First .. + Invocation_Constructs.Last + loop + Processor.all (IC_Id); + end loop; + end For_Each_Invocation_Construct; + + ----------------------------------- + -- For_Each_Invocation_Construct -- + ----------------------------------- + + procedure For_Each_Invocation_Construct + (U_Id : Unit_Id; + Processor : Invocation_Construct_Processor_Ptr) + is + pragma Assert (Present (U_Id)); + pragma Assert (Processor /= null); + + U_Rec : Unit_Record renames Units.Table (U_Id); + + begin + for IC_Id in U_Rec.First_Invocation_Construct .. + U_Rec.Last_Invocation_Construct + loop + Processor.all (IC_Id); + end loop; + end For_Each_Invocation_Construct; + + ---------------------------------- + -- For_Each_Invocation_Relation -- + ---------------------------------- + + procedure For_Each_Invocation_Relation + (Processor : Invocation_Relation_Processor_Ptr) + is + begin + pragma Assert (Processor /= null); + + for IR_Id in Invocation_Relations.First .. + Invocation_Relations.Last + loop + Processor.all (IR_Id); + end loop; + end For_Each_Invocation_Relation; + + ---------------------------------- + -- For_Each_Invocation_Relation -- + ---------------------------------- + + procedure For_Each_Invocation_Relation + (U_Id : Unit_Id; + Processor : Invocation_Relation_Processor_Ptr) + is + pragma Assert (Present (U_Id)); + pragma Assert (Processor /= null); + + U_Rec : Unit_Record renames Units.Table (U_Id); + + begin + for IR_Id in U_Rec.First_Invocation_Relation .. + U_Rec.Last_Invocation_Relation + loop + Processor.all (IR_Id); + end loop; + end For_Each_Invocation_Relation; + ---------- -- Hash -- ---------- @@ -428,6 +684,26 @@ package body ALI is return Invocation_Construct_Codes (Kind); end Invocation_Construct_Kind_To_Code; + ------------------------------- + -- Invocation_Graph_Encoding -- + ------------------------------- + + function Invocation_Graph_Encoding return Invocation_Graph_Encoding_Kind is + begin + return Compile_Time_Invocation_Graph_Encoding; + end Invocation_Graph_Encoding; + + -------------------------------------------- + -- Invocation_Graph_Encoding_Kind_To_Code -- + -------------------------------------------- + + function Invocation_Graph_Encoding_Kind_To_Code + (Kind : Invocation_Graph_Encoding_Kind) return Character + is + begin + return Invocation_Graph_Encoding_Codes (Kind); + end Invocation_Graph_Encoding_Kind_To_Code; + ---------------------------------------- -- Invocation_Graph_Line_Kind_To_Code -- ---------------------------------------- @@ -489,6 +765,70 @@ package body ALI is end Invocation_Signature_Of; ------------- + -- Invoker -- + ------------- + + function Invoker + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Invoker; + end Invoker; + + ---------- + -- Kind -- + ---------- + + function Kind + (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Kind; + end Kind; + + ---------- + -- Kind -- + ---------- + + function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Kind; + end Kind; + + ---------- + -- Line -- + ---------- + + function Line (IS_Id : Invocation_Signature_Id) return Nat is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Line; + end Line; + + --------------- + -- Locations -- + --------------- + + function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Locations; + end Locations; + + ---------- + -- Name -- + ---------- + + function Name (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Name; + end Name; + + ------------- -- Present -- ------------- @@ -638,7 +978,7 @@ package body ALI is -- -- If Ignore_Special is False (normal case), the scan is terminated by -- a typeref bracket or an equal sign except for the special case of - -- an operator name starting with a double quote which is terminated + -- an operator name starting with a double quote that is terminated -- by another double quote. -- -- If May_Be_Quoted is True and the first non blank character is '"' @@ -674,7 +1014,7 @@ package body ALI is -- Parse the definition of a typeref (<...>, {...} or (...)) procedure Scan_Invocation_Graph_Line; - -- Parse a single line which encodes a piece of the invocation graph + -- Parse a single line that encodes a piece of the invocation graph procedure Skip_Eol; -- Skip past spaces, then skip past end of line (fatal error if not @@ -1204,6 +1544,13 @@ package body ALI is -- * Invocation_Constructs -- * Units + procedure Scan_Invocation_Graph_Attributes_Line; + pragma Inline (Scan_Invocation_Graph_Attributes_Line); + -- Parse an invocation-graph attributes line. The following data + -- structures are updated: + -- + -- * Units + procedure Scan_Invocation_Relation_Line; pragma Inline (Scan_Invocation_Relation_Line); -- Parse an invocation relation line and construct the corresponding @@ -1225,51 +1572,78 @@ package body ALI is ------------------------------------ procedure Scan_Invocation_Construct_Line is - IC_Rec : Invocation_Construct_Record; + Body_Placement : Declaration_Placement_Kind; + Kind : Invocation_Construct_Kind; + Signature : Invocation_Signature_Id; + Spec_Placement : Declaration_Placement_Kind; begin -- construct-kind - IC_Rec.Kind := Code_To_Invocation_Construct_Kind (Getc); + Kind := Code_To_Invocation_Construct_Kind (Getc); + Checkc (' '); + Skip_Space; + + -- construct-spec-placement + + Spec_Placement := Code_To_Declaration_Placement_Kind (Getc); Checkc (' '); Skip_Space; -- construct-body-placement - IC_Rec.Placement := Code_To_Body_Placement_Kind (Getc); + Body_Placement := Code_To_Declaration_Placement_Kind (Getc); Checkc (' '); Skip_Space; -- construct-signature - IC_Rec.Signature := Scan_Invocation_Signature; - pragma Assert (Present (IC_Rec.Signature)); - + Signature := Scan_Invocation_Signature; Skip_Eol; - Add_Invocation_Construct (IC_Rec); + Add_Invocation_Construct + (Body_Placement => Body_Placement, + Kind => Kind, + Signature => Signature, + Spec_Placement => Spec_Placement); end Scan_Invocation_Construct_Line; + ------------------------------------------- + -- Scan_Invocation_Graph_Attributes_Line -- + ------------------------------------------- + + procedure Scan_Invocation_Graph_Attributes_Line is + begin + -- encoding-kind + + Set_Invocation_Graph_Encoding + (Code_To_Invocation_Graph_Encoding_Kind (Getc)); + Skip_Eol; + end Scan_Invocation_Graph_Attributes_Line; + ----------------------------------- -- Scan_Invocation_Relation_Line -- ----------------------------------- procedure Scan_Invocation_Relation_Line is - IR_Rec : Invocation_Relation_Record; + Extra : Name_Id; + Invoker : Invocation_Signature_Id; + Kind : Invocation_Kind; + Target : Invocation_Signature_Id; begin -- relation-kind - IR_Rec.Kind := Code_To_Invocation_Kind (Getc); + Kind := Code_To_Invocation_Kind (Getc); Checkc (' '); Skip_Space; -- (extra-name | "none") - IR_Rec.Extra := Get_Name; + Extra := Get_Name; - if IR_Rec.Extra = Name_None then - IR_Rec.Extra := No_Name; + if Extra = Name_None then + Extra := No_Name; end if; Checkc (' '); @@ -1277,20 +1651,20 @@ package body ALI is -- invoker-signature - IR_Rec.Invoker := Scan_Invocation_Signature; - pragma Assert (Present (IR_Rec.Invoker)); - + Invoker := Scan_Invocation_Signature; Checkc (' '); Skip_Space; -- target-signature - IR_Rec.Target := Scan_Invocation_Signature; - pragma Assert (Present (IR_Rec.Target)); - + Target := Scan_Invocation_Signature; Skip_Eol; - Add_Invocation_Relation (IR_Rec); + Add_Invocation_Relation + (Extra => Extra, + Invoker => Invoker, + Kind => Kind, + Target => Target); end Scan_Invocation_Relation_Line; ------------------------------- @@ -1378,13 +1752,16 @@ package body ALI is -- line-attributes - if Line = Invocation_Construct_Line then - Scan_Invocation_Construct_Line; + case Line is + when Invocation_Construct_Line => + Scan_Invocation_Construct_Line; - else - pragma Assert (Line = Invocation_Relation_Line); - Scan_Invocation_Relation_Line; - end if; + when Invocation_Graph_Attributes_Line => + Scan_Invocation_Graph_Attributes_Line; + + when Invocation_Relation_Line => + Scan_Invocation_Relation_Line; + end case; end Scan_Invocation_Graph_Line; -------------- @@ -1496,6 +1873,7 @@ package body ALI is First_Specific_Dispatching => Specific_Dispatching.Last + 1, First_Unit => No_Unit_Id, GNATprove_Mode => False, + Invocation_Graph_Encoding => No_Encoding, Last_Interrupt_State => Interrupt_States.Last, Last_Sdep => No_Sdep_Id, Last_Specific_Dispatching => Specific_Dispatching.Last, @@ -3064,7 +3442,7 @@ package body ALI is ALIs.Table (Id).Last_Sdep := Sdep.Last; - -- Loop through invocation graph lines + -- Loop through invocation-graph lines G_Loop : loop Check_Unknown_Line; @@ -3436,6 +3814,16 @@ package body ALI is return No_ALI_Id; end Scan_ALI; + ----------- + -- Scope -- + ----------- + + function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is + begin + pragma Assert (Present (IS_Id)); + return Invocation_Signatures.Table (IS_Id).Scope; + end Scope; + --------- -- SEq -- --------- @@ -3445,6 +3833,31 @@ package body ALI is return F1.all = F2.all; end SEq; + ----------------------------------- + -- Set_Invocation_Graph_Encoding -- + ----------------------------------- + + procedure Set_Invocation_Graph_Encoding + (Kind : Invocation_Graph_Encoding_Kind; + Update_Units : Boolean := True) + is + begin + Compile_Time_Invocation_Graph_Encoding := Kind; + + -- Update the invocation-graph encoding of the current unit only when + -- requested by the caller. + + if Update_Units then + declare + Curr_Unit : Unit_Record renames Units.Table (Units.Last); + Curr_ALI : ALIs_Record renames ALIs.Table (Curr_Unit.My_ALI); + + begin + Curr_ALI.Invocation_Graph_Encoding := Kind; + end; + end if; + end Set_Invocation_Graph_Encoding; + ----------- -- SHash -- ----------- @@ -3461,4 +3874,40 @@ package body ALI is return Vindex (Vindex'First + Vindex (H mod Vindex'Range_Length)); end SHash; + --------------- + -- Signature -- + --------------- + + function Signature + (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Signature; + end Signature; + + -------------------- + -- Spec_Placement -- + -------------------- + + function Spec_Placement + (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind + is + begin + pragma Assert (Present (IC_Id)); + return Invocation_Constructs.Table (IC_Id).Spec_Placement; + end Spec_Placement; + + ------------ + -- Target -- + ------------ + + function Target + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id + is + begin + pragma Assert (Present (IR_Id)); + return Invocation_Relations.Table (IR_Id).Target; + end Target; + end ALI; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 79eabb1..fc6e592 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -112,6 +112,20 @@ package ALI is First_ALI_Entry : constant ALI_Id := No_ALI_Id + 1; -- Id of first actual entry in table + -- The following type enumerates all possible invocation-graph encoding + -- kinds. + + type Invocation_Graph_Encoding_Kind is + (Endpoints_Encoding, + -- The invocation construct and relation lines contain information for + -- the start construct and end target found on an invocation-graph path. + + Full_Path_Encoding, + -- The invocation construct and relation lines contain information for + -- all constructs and targets found on a invocation-graph path. + + No_Encoding); + type Main_Program_Type is (None, Proc, Func); -- Indicator of whether unit can be used as main program @@ -212,7 +226,7 @@ package ALI is No_Component_Reordering : Boolean; -- Set to True if file was compiled with a configuration pragma file - -- containing pragma No_Component_Reordering. Not set if 'P' appears + -- containing pragma No_Component_Reordering. Not set if 'P' appears -- in Ignore_Lines. No_Object : Boolean; @@ -259,6 +273,11 @@ package ALI is -- Last_Specific_Dispatching = First_Specific_Dispatching - 1. That -- is why the 'Base reference is there, it can be one less than the -- lower bound of the subtype. Not set if 'S' appears in Ignore_Lines. + + Invocation_Graph_Encoding : Invocation_Graph_Encoding_Kind; + -- The encoding format used to capture information about the invocation + -- constructs and relations within the corresponding ALI file of this + -- unit. end record; No_Main_Priority : constant Int := -1; @@ -1087,6 +1106,20 @@ package ALI is -- Invocation Graph Types -- ---------------------------- + -- The following type identifies an invocation construct + + No_Invocation_Construct : constant Invocation_Construct_Id := + Invocation_Construct_Id'First; + First_Invocation_Construct : constant Invocation_Construct_Id := + No_Invocation_Construct + 1; + + -- The following type identifies an invocation relation + + No_Invocation_Relation : constant Invocation_Relation_Id := + Invocation_Relation_Id'First; + First_Invocation_Relation : constant Invocation_Relation_Id := + No_Invocation_Relation + 1; + -- The following type identifies an invocation signature No_Invocation_Signature : constant Invocation_Signature_Id := @@ -1094,59 +1127,20 @@ package ALI is First_Invocation_Signature : constant Invocation_Signature_Id := No_Invocation_Signature + 1; - -- The following type represents an invocation signature. Its purpose is - -- to uniquely identify an invocation construct within the ALI space. The - -- signature is comprised out of several pieces, some of which are used in - -- error diagnostics by the binder. Identification issues are resolved as - -- follows: - -- - -- * The Column, Line, and Locations attributes together differentiate - -- between homonyms. In most cases, the Column and Line are sufficient - -- except when generic instantiations are involved. Together, the three - -- attributes offer a sequence of column-line pairs which eventually - -- reflect the location within the generic template. - -- - -- * The Name attribute differentiates between invocation constructs at - -- the scope level. Since it is illegal for two entities with the same - -- name to coexist in the same scope, the Name attribute is sufficient - -- to distinguish them. Overloaded entities are already handled by the - -- Column, Line, and Locations attributes. - -- - -- * The Scope attribute differentiates between invocation constructs at - -- various levels of nesting. - - type Invocation_Signature_Record is record - Column : Nat := 0; - -- The column number where the invocation construct is declared - - Line : Nat := 0; - -- The line number where the invocation construct is declared - - Locations : Name_Id := No_Name; - -- Sequence of column and line numbers within nested instantiations - - Name : Name_Id := No_Name; - -- The name of the invocation construct - - Scope : Name_Id := No_Name; - -- The qualified name of the scope where the invocation construct is - -- declared. - end record; - -- The following type enumerates all possible placements of an invocation - -- construct's body body with respect to the unit it is declared in. + -- construct's spec and body with respect to the unit it is declared in. - type Body_Placement_Kind is + type Declaration_Placement_Kind is (In_Body, - -- The body of the invocation construct is within the body of the unit - -- it is declared in. + -- The declaration of the invocation construct is within the body of the + -- unit it is declared in. In_Spec, - -- The body of the invocation construct is within the spec of the unit - -- it is declared in. + -- The declaration of the invocation construct is within the spec of the + -- unit it is declared in. - No_Body_Placement); - -- The invocation construct does not have a body + No_Declaration_Placement); + -- The invocation construct does not have a declaration -- The following type enumerates all possible invocation construct kinds @@ -1162,35 +1156,6 @@ package ALI is Regular_Construct); -- The invocation construct is a normal invocation construct - -- The following type identifies an invocation construct - - No_Invocation_Construct : constant Invocation_Construct_Id := - Invocation_Construct_Id'First; - First_Invocation_Construct : constant Invocation_Construct_Id := - No_Invocation_Construct + 1; - - -- The following type represents an invocation construct - - type Invocation_Construct_Record is record - Kind : Invocation_Construct_Kind := Regular_Construct; - -- The nature of the invocation construct - - Placement : Body_Placement_Kind := No_Body_Placement; - -- The location of the invocation construct's body with respect to the - -- body of the unit it is declared in. - - Signature : Invocation_Signature_Id := No_Invocation_Signature; - -- The invocation signature which uniquely identifies the invocation - -- construct in the ALI space. - end record; - - -- The following type identifies an invocation relation - - No_Invocation_Relation : constant Invocation_Relation_Id := - Invocation_Relation_Id'First; - First_Invocation_Relation : constant Invocation_Relation_Id := - No_Invocation_Relation + 1; - -- The following type enumerates all possible invocation kinds type Invocation_Kind is @@ -1220,94 +1185,60 @@ package ALI is -- Internal_Controlled_Finalization Internal_Controlled_Initialization; - -- The following type represents an invocation relation. It associates an - -- invoker which activates/calls/instantiates with a target. - - type Invocation_Relation_Record is record - Extra : Name_Id := No_Name; - -- The name of an additional entity used in error diagnostics - - Invoker : Invocation_Signature_Id := No_Invocation_Signature; - -- The invocation signature which uniquely identifies the invoker within - -- the ALI space. - - Kind : Invocation_Kind := No_Invocation; - -- The nature of the invocation - - Target : Invocation_Signature_Id := No_Invocation_Signature; - -- The invocation signature which uniquely identifies the target within - -- the ALI space. - end record; - - -- The following type enumerates all possible invocation graph ALI lines + -- The following type enumerates all possible invocation-graph ALI lines type Invocation_Graph_Line_Kind is (Invocation_Construct_Line, + Invocation_Graph_Attributes_Line, Invocation_Relation_Line); - -------------------------------------- - -- Invocation Graph Data Structures -- - -------------------------------------- - - package Invocation_Constructs is new Table.Table - (Table_Index_Type => Invocation_Construct_Id, - Table_Component_Type => Invocation_Construct_Record, - Table_Low_Bound => First_Invocation_Construct, - Table_Initial => 2500, - Table_Increment => 200, - Table_Name => "Invocation_Constructs"); - - package Invocation_Relations is new Table.Table - (Table_Index_Type => Invocation_Relation_Id, - Table_Component_Type => Invocation_Relation_Record, - Table_Low_Bound => First_Invocation_Relation, - Table_Initial => 2500, - Table_Increment => 200, - Table_Name => "Invocation_Relation"); - - package Invocation_Signatures is new Table.Table - (Table_Index_Type => Invocation_Signature_Id, - Table_Component_Type => Invocation_Signature_Record, - Table_Low_Bound => First_Invocation_Signature, - Table_Initial => 2500, - Table_Increment => 200, - Table_Name => "Invocation_Signatures"); - ---------------------------------- -- Invocation Graph Subprograms -- ---------------------------------- procedure Add_Invocation_Construct - (IC_Rec : Invocation_Construct_Record; - Update_Units : Boolean := True); + (Body_Placement : Declaration_Placement_Kind; + Kind : Invocation_Construct_Kind; + Signature : Invocation_Signature_Id; + Spec_Placement : Declaration_Placement_Kind; + Update_Units : Boolean := True); pragma Inline (Add_Invocation_Construct); - -- Add invocation construct attributes IC_Rec to internal data structures. - -- Flag Undate_Units should be set when this addition must be reflected in - -- the attributes of the current unit. + -- Add a new invocation construct described by its attributes. Update_Units + -- should be set when this addition must be reflected in the attributes of + -- the current unit. procedure Add_Invocation_Relation - (IR_Rec : Invocation_Relation_Record; + (Extra : Name_Id; + Invoker : Invocation_Signature_Id; + Kind : Invocation_Kind; + Target : Invocation_Signature_Id; Update_Units : Boolean := True); pragma Inline (Add_Invocation_Relation); - -- Add invocation relation attributes IR_Rec to internal data structures. - -- Flag Undate_Units should be set when this addition must be reflected in - -- the attributes of the current unit. + -- Add a new invocation relation described by its attributes. Update_Units + -- should be set when this addition must be reflected in the attributes of + -- the current unit. - function Body_Placement_Kind_To_Code - (Kind : Body_Placement_Kind) return Character; - pragma Inline (Body_Placement_Kind_To_Code); - -- Obtain the character encoding of body placement kind Kind + function Body_Placement + (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind; + pragma Inline (Body_Placement); + -- Obtain the location of invocation construct IC_Id's body with respect to + -- the unit where it is declared. - function Code_To_Body_Placement_Kind - (Code : Character) return Body_Placement_Kind; - pragma Inline (Code_To_Body_Placement_Kind); - -- Obtain the body placement kind of character encoding Code + function Code_To_Declaration_Placement_Kind + (Code : Character) return Declaration_Placement_Kind; + pragma Inline (Code_To_Declaration_Placement_Kind); + -- Obtain the declaration placement kind of character encoding Code function Code_To_Invocation_Construct_Kind (Code : Character) return Invocation_Construct_Kind; pragma Inline (Code_To_Invocation_Construct_Kind); -- Obtain the invocation construct kind of character encoding Code + function Code_To_Invocation_Graph_Encoding_Kind + (Code : Character) return Invocation_Graph_Encoding_Kind; + pragma Inline (Code_To_Invocation_Graph_Encoding_Kind); + -- Obtain the invocation-graph encoding kind of character encoding Code + function Code_To_Invocation_Kind (Code : Character) return Invocation_Kind; pragma Inline (Code_To_Invocation_Kind); @@ -1316,17 +1247,70 @@ package ALI is function Code_To_Invocation_Graph_Line_Kind (Code : Character) return Invocation_Graph_Line_Kind; pragma Inline (Code_To_Invocation_Graph_Line_Kind); - -- Obtain the invocation graph line kind of character encoding Code + -- Obtain the invocation-graph line kind of character encoding Code + + function Column (IS_Id : Invocation_Signature_Id) return Nat; + pragma Inline (Column); + -- Obtain the column number of invocation signature IS_Id + + function Declaration_Placement_Kind_To_Code + (Kind : Declaration_Placement_Kind) return Character; + pragma Inline (Declaration_Placement_Kind_To_Code); + -- Obtain the character encoding of declaration placement kind Kind + + function Extra (IR_Id : Invocation_Relation_Id) return Name_Id; + pragma Inline (Extra); + -- Obtain the name of the additional entity used in error diagnostics for + -- invocation relation IR_Id. + + type Invocation_Construct_Processor_Ptr is + access procedure (IC_Id : Invocation_Construct_Id); + + procedure For_Each_Invocation_Construct + (Processor : Invocation_Construct_Processor_Ptr); + pragma Inline (For_Each_Invocation_Construct); + -- Invoke Processor on each invocation construct + + procedure For_Each_Invocation_Construct + (U_Id : Unit_Id; + Processor : Invocation_Construct_Processor_Ptr); + pragma Inline (For_Each_Invocation_Construct); + -- Invoke Processor on each invocation construct of unit U_Id + + type Invocation_Relation_Processor_Ptr is + access procedure (IR_Id : Invocation_Relation_Id); + + procedure For_Each_Invocation_Relation + (Processor : Invocation_Relation_Processor_Ptr); + pragma Inline (For_Each_Invocation_Relation); + -- Invoke Processor on each invocation relation + + procedure For_Each_Invocation_Relation + (U_Id : Unit_Id; + Processor : Invocation_Relation_Processor_Ptr); + pragma Inline (For_Each_Invocation_Relation); + -- Invoke Processor on each invocation relation of unit U_Id function Invocation_Construct_Kind_To_Code (Kind : Invocation_Construct_Kind) return Character; pragma Inline (Invocation_Construct_Kind_To_Code); -- Obtain the character encoding of invocation kind Kind + function Invocation_Graph_Encoding return Invocation_Graph_Encoding_Kind; + pragma Inline (Invocation_Graph_Encoding); + -- Obtain the encoding format used to capture information about the + -- invocation constructs and relations within the ALI file of the main + -- unit. + + function Invocation_Graph_Encoding_Kind_To_Code + (Kind : Invocation_Graph_Encoding_Kind) return Character; + pragma Inline (Invocation_Graph_Encoding_Kind_To_Code); + -- Obtain the character encoding for invocation-graph encoding kind Kind + function Invocation_Graph_Line_Kind_To_Code (Kind : Invocation_Graph_Line_Kind) return Character; pragma Inline (Invocation_Graph_Line_Kind_To_Code); - -- Obtain the character encoding for invocation like kind Kind + -- Obtain the character encoding for invocation line kind Kind function Invocation_Kind_To_Code (Kind : Invocation_Kind) return Character; @@ -1342,6 +1326,63 @@ package ALI is pragma Inline (Invocation_Signature_Of); -- Obtain the invocation signature that corresponds to the input attributes + function Invoker + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; + pragma Inline (Invoker); + -- Obtain the signature of the invocation relation IR_Id's invoker + + function Kind + (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind; + pragma Inline (Kind); + -- Obtain the nature of invocation construct IC_Id + + function Kind + (IR_Id : Invocation_Relation_Id) return Invocation_Kind; + pragma Inline (Kind); + -- Obtain the nature of invocation relation IR_Id + + function Line (IS_Id : Invocation_Signature_Id) return Nat; + pragma Inline (Line); + -- Obtain the line number of invocation signature IS_Id + + function Locations (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Locations); + -- Obtain the sequence of column and line numbers within nested instances + -- of invocation signature IS_Id + + function Name (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Name); + -- Obtain the name of invocation signature IS_Id + + function Scope (IS_Id : Invocation_Signature_Id) return Name_Id; + pragma Inline (Scope); + -- Obtain the scope of invocation signature IS_Id + + procedure Set_Invocation_Graph_Encoding + (Kind : Invocation_Graph_Encoding_Kind; + Update_Units : Boolean := True); + pragma Inline (Set_Invocation_Graph_Encoding); + -- Set the encoding format used to capture information about the invocation + -- constructs and relations within the ALI file of the main unit to Kind. + -- Update_Units should be set when this action must be reflected in the + -- attributes of the current unit. + + function Signature + (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id; + pragma Inline (Signature); + -- Obtain the signature of invocation construct IC_Id + + function Spec_Placement + (IC_Id : Invocation_Construct_Id) return Declaration_Placement_Kind; + pragma Inline (Spec_Placement); + -- Obtain the location of invocation construct IC_Id's spec with respect to + -- the unit where it is declared. + + function Target + (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; + pragma Inline (Target); + -- Obtain the signature of the invocation relation IR_Id's target + -------------------------------------- -- Subprograms for Reading ALI File -- -------------------------------------- diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index 18bf1e4a..f5faecb 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -116,6 +116,9 @@ package Alloc is Rep_Table_Initial : constant := 1000; -- Repinfo Rep_Table_Increment : constant := 200; + Rep_JSON_Table_Initial : constant := 10; -- Repinfo + Rep_JSON_Table_Increment : constant := 200; + Scope_Stack_Initial : constant := 10; -- Sem Scope_Stack_Increment : constant := 200; diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c index 3249c32..ca82ed5 100644 --- a/gcc/ada/argv.c +++ b/gcc/ada/argv.c @@ -43,9 +43,8 @@ Ada.Command_Line.Environment package. */ #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" -#include <sys/stat.h> +#include "runtime.h" +#include <string.h> #else #include "config.h" #include "system.h" diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 76fa6c8..54c0e56 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -225,7 +225,10 @@ package body Aspects is Owner := Root_Type (Owner); end if; - if Is_Private_Type (Owner) and then Present (Full_View (Owner)) then + if Is_Private_Type (Owner) + and then Present (Full_View (Owner)) + and then not Operational_Aspect (A) + then Owner := Full_View (Owner); end if; end if; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 9190a635..2a6acc2 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -277,6 +277,20 @@ package Aspects is Aspect_Warnings => True, others => False); + -- The following array indicates aspects that specify operational + -- characteristics, and thus are view-specific. Representation + -- aspects break privacy, as they are needed during expansion and + -- code generation. + -- List is currently incomplete ??? + + Operational_Aspect : constant array (Aspect_Id) of Boolean := + (Aspect_Constant_Indexing => True, + Aspect_Default_Iterator => True, + Aspect_Iterator_Element => True, + Aspect_Iterable => True, + Aspect_Variable_Indexing => True, + others => False); + -- The following array indicates aspects for which multiple occurrences of -- the same aspect attached to the same declaration are allowed. diff --git a/gcc/ada/aux-io.c b/gcc/ada/aux-io.c index b55a6f9..e022b65 100644 --- a/gcc/ada/aux-io.c +++ b/gcc/ada/aux-io.c @@ -31,10 +31,7 @@ #include <stdio.h> -#ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" -#else +#ifndef IN_RTS #include "config.h" #include "system.h" #endif diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index e135540..8ea8a6b 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -1810,9 +1810,11 @@ package body Bindgen is -- with a pragma Volatile in order to tell the compiler to preserve -- this variable at any level of optimization. - -- CodePeer and CCG do not need this extra code on the other hand + -- CodePeer and CCG do not need this extra code. The code is also not + -- needed if the binder is in "Minimal Binder" mode. if Bind_Main_Program + and then not Minimal_Binder and then not CodePeer_Mode and then not Generate_C_Code then @@ -2354,25 +2356,27 @@ package body Bindgen is -- program uses two Ada libraries). Also zero terminate the string -- so that its end can be found reliably at run time. - WBI (""); - WBI (" GNAT_Version : constant String :="); - WBI (" """ & Ver_Prefix & - Gnat_Version_String & - """ & ASCII.NUL;"); - WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); + if not Minimal_Binder then + WBI (""); + WBI (" GNAT_Version : constant String :="); + WBI (" """ & Ver_Prefix & + Gnat_Version_String & + """ & ASCII.NUL;"); + WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");"); - WBI (""); - Set_String (" Ada_Main_Program_Name : constant String := """); - Get_Name_String (Units.Table (First_Unit_Entry).Uname); + WBI (""); + Set_String (" Ada_Main_Program_Name : constant String := """); + Get_Name_String (Units.Table (First_Unit_Entry).Uname); - Set_Main_Program_Name; - Set_String (""" & ASCII.NUL;"); + Set_Main_Program_Name; + Set_String (""" & ASCII.NUL;"); - Write_Statement_Buffer; + Write_Statement_Buffer; - WBI - (" pragma Export (C, Ada_Main_Program_Name, " & - """__gnat_ada_main_program_name"");"); + WBI + (" pragma Export (C, Ada_Main_Program_Name, " & + """__gnat_ada_main_program_name"");"); + end if; end if; WBI (""); diff --git a/gcc/ada/bindo-augmentors.adb b/gcc/ada/bindo-augmentors.adb index f97f0d0..57fb541 100644 --- a/gcc/ada/bindo-augmentors.adb +++ b/gcc/ada/bindo-augmentors.adb @@ -27,10 +27,9 @@ with Debug; use Debug; with Output; use Output; with Types; use Types; -with Bindo.Writers; use Bindo.Writers; - -with GNAT; use GNAT; -with GNAT.Sets; use GNAT.Sets; +with Bindo.Writers; +use Bindo.Writers; +use Bindo.Writers.Phase_Writers; package body Bindo.Augmentors is @@ -40,24 +39,6 @@ package body Bindo.Augmentors is package body Library_Graph_Augmentors is - ----------------- - -- Visited set -- - ----------------- - - package VS is new Membership_Sets - (Element_Type => Invocation_Graph_Vertex_Id, - "=" => "=", - Hash => Hash_Invocation_Graph_Vertex); - use VS; - - ----------------- - -- Global data -- - ----------------- - - Inv_Graph : Invocation_Graph := Invocation_Graphs.Nil; - Lib_Graph : Library_Graph := Library_Graphs.Nil; - Visited : Membership_Set := VS.Nil; - ---------------- -- Statistics -- ---------------- @@ -74,20 +55,10 @@ package body Bindo.Augmentors is -- Local subprograms -- ----------------------- - function Is_Visited - (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean; - pragma Inline (Is_Visited); - -- Determine whether invocation graph vertex IGV_Id has been visited - -- during the traversal. - - procedure Set_Is_Visited - (IGV_Id : Invocation_Graph_Vertex_Id; - Val : Boolean := True); - pragma Inline (Set_Is_Visited); - -- Mark invocation graph vertex IGV_Id as visited during the traversal - -- depending on value Val. - - procedure Visit_Elaboration_Root (Root : Invocation_Graph_Vertex_Id); + procedure Visit_Elaboration_Root + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Root : Invocation_Graph_Vertex_Id); pragma Inline (Visit_Elaboration_Root); -- Start a DFS traversal from elaboration root Root to: -- @@ -96,7 +67,9 @@ package body Bindo.Augmentors is -- * Create invocation edges for each such transition where the -- successor is Root. - procedure Visit_Elaboration_Roots; + procedure Visit_Elaboration_Roots + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph); pragma Inline (Visit_Elaboration_Roots); -- Start a DFS traversal from all elaboration roots to: -- @@ -106,26 +79,30 @@ package body Bindo.Augmentors is -- successor is the current root. procedure Visit_Vertex - (Curr_IGV_Id : Invocation_Graph_Vertex_Id; - Last_LGV_Id : Library_Graph_Vertex_Id; - Root_LGV_Id : Library_Graph_Vertex_Id; - Internal_Ctrl : Boolean; - Path : Natural); + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Invoker : Invocation_Graph_Vertex_Id; + Last_Vertex : Library_Graph_Vertex_Id; + Root_Vertex : Library_Graph_Vertex_Id; + Visited_Invokers : IGV_Sets.Membership_Set; + Activates_Task : Boolean; + Internal_Controlled_Action : Boolean; + Path : Natural); pragma Inline (Visit_Vertex); - -- Visit invocation graph vertex Curr_IGV_Id to: + -- Visit invocation graph vertex Invoker to: -- -- * Detect a transition from the last library graph vertex denoted by - -- Last_LGV_Id to the library graph vertex of Curr_IGV_Id. + -- Last_Vertex to the library graph vertex of Invoker. -- -- * Create an invocation edge in library graph Lib_Graph to reflect -- the transition, where the predecessor is the library graph vertex - -- or Curr_IGV_Id, and the successor is Root_LGV_Id. + -- or Invoker, and the successor is Root_Vertex. -- - -- * Visit the neighbours of Curr_IGV_Id. + -- * Visit the neighbours of Invoker. -- - -- Flag Internal_Ctrl should be set when the DFS traversal visited an - -- internal controlled invocation edge. Path denotes the length of the - -- path. + -- Flag Internal_Controlled_Action should be set when the DFS traversal + -- visited an internal controlled invocation edge. Path is the length of + -- the path. procedure Write_Statistics; pragma Inline (Write_Statistics); @@ -137,109 +114,100 @@ package body Bindo.Augmentors is --------------------------- procedure Augment_Library_Graph - (Inv_G : Invocation_Graph; - Lib_G : Library_Graph) + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph) is begin - pragma Assert (Present (Lib_G)); + pragma Assert (Present (Lib_Graph)); -- Nothing to do when there is no invocation graph - if not Present (Inv_G) then + if not Present (Inv_Graph) then return; end if; - -- Prepare the global data. Note that Visited is initialized for each - -- elaboration root. + Start_Phase (Library_Graph_Augmentation); + + -- Prepare the statistics data - Inv_Graph := Inv_G; - Lib_Graph := Lib_G; Longest_Path := 0; Total_Visited := 0; - Visit_Elaboration_Roots; + Visit_Elaboration_Roots (Inv_Graph, Lib_Graph); Write_Statistics; - end Augment_Library_Graph; - - ---------------- - -- Is_Visited -- - ---------------- - - function Is_Visited - (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean - is - begin - pragma Assert (Present (Visited)); - pragma Assert (Present (IGV_Id)); - - return Contains (Visited, IGV_Id); - end Is_Visited; - -------------------- - -- Set_Is_Visited -- - -------------------- - - procedure Set_Is_Visited - (IGV_Id : Invocation_Graph_Vertex_Id; - Val : Boolean := True) - is - begin - pragma Assert (Present (Visited)); - pragma Assert (Present (IGV_Id)); - - if Val then - Insert (Visited, IGV_Id); - else - Delete (Visited, IGV_Id); - end if; - end Set_Is_Visited; + End_Phase (Library_Graph_Augmentation); + end Augment_Library_Graph; ---------------------------- -- Visit_Elaboration_Root -- ---------------------------- - procedure Visit_Elaboration_Root (Root : Invocation_Graph_Vertex_Id) is + procedure Visit_Elaboration_Root + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Root : Invocation_Graph_Vertex_Id) + is pragma Assert (Present (Inv_Graph)); - pragma Assert (Present (Root)); pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Root)); - Root_LGV_Id : constant Library_Graph_Vertex_Id := - Lib_Vertex (Inv_Graph, Root); + Root_Vertex : constant Library_Graph_Vertex_Id := + Body_Vertex (Inv_Graph, Root); - pragma Assert (Present (Root_LGV_Id)); + Visited : IGV_Sets.Membership_Set; begin + -- Nothing to do when the unit where the elaboration root resides + -- lacks elaboration code. This implies that any invocation edges + -- going out of the unit are unwanted. This behavior emulates the + -- old elaboration order mechanism. + + if Has_No_Elaboration_Code (Lib_Graph, Root_Vertex) then + return; + end if; + -- Prepare the global data - Visited := Create (Number_Of_Vertices (Inv_Graph)); + Visited := IGV_Sets.Create (Number_Of_Vertices (Inv_Graph)); Visit_Vertex - (Curr_IGV_Id => Root, - Last_LGV_Id => Root_LGV_Id, - Root_LGV_Id => Root_LGV_Id, - Internal_Ctrl => False, - Path => 0); - - Destroy (Visited); + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Invoker => Root, + Last_Vertex => Root_Vertex, + Root_Vertex => Root_Vertex, + Visited_Invokers => Visited, + Activates_Task => False, + Internal_Controlled_Action => False, + Path => 0); + + IGV_Sets.Destroy (Visited); end Visit_Elaboration_Root; ----------------------------- -- Visit_Elaboration_Roots -- ----------------------------- - procedure Visit_Elaboration_Roots is + procedure Visit_Elaboration_Roots + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph) + is Iter : Elaboration_Root_Iterator; Root : Invocation_Graph_Vertex_Id; begin pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); Iter := Iterate_Elaboration_Roots (Inv_Graph); while Has_Next (Iter) loop Next (Iter, Root); - pragma Assert (Present (Root)); - Visit_Elaboration_Root (Root); + Visit_Elaboration_Root + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Root => Root); end loop; end Visit_Elaboration_Roots; @@ -248,34 +216,39 @@ package body Bindo.Augmentors is ------------------ procedure Visit_Vertex - (Curr_IGV_Id : Invocation_Graph_Vertex_Id; - Last_LGV_Id : Library_Graph_Vertex_Id; - Root_LGV_Id : Library_Graph_Vertex_Id; - Internal_Ctrl : Boolean; - Path : Natural) + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Invoker : Invocation_Graph_Vertex_Id; + Last_Vertex : Library_Graph_Vertex_Id; + Root_Vertex : Library_Graph_Vertex_Id; + Visited_Invokers : IGV_Sets.Membership_Set; + Activates_Task : Boolean; + Internal_Controlled_Action : Boolean; + Path : Natural) is New_Path : constant Natural := Path + 1; - Curr_LGV_Id : Library_Graph_Vertex_Id; - IGE_Id : Invocation_Graph_Edge_Id; - Iter : Edges_To_Targets_Iterator; - Targ : Invocation_Graph_Vertex_Id; + Edge : Invocation_Graph_Edge_Id; + Edge_Kind : Invocation_Kind; + Invoker_Vertex : Library_Graph_Vertex_Id; + Iter : Edges_To_Targets_Iterator; begin pragma Assert (Present (Inv_Graph)); - pragma Assert (Present (Curr_IGV_Id)); pragma Assert (Present (Lib_Graph)); - pragma Assert (Present (Last_LGV_Id)); - pragma Assert (Present (Root_LGV_Id)); + pragma Assert (Present (Invoker)); + pragma Assert (Present (Last_Vertex)); + pragma Assert (Present (Root_Vertex)); + pragma Assert (IGV_Sets.Present (Visited_Invokers)); -- Nothing to do when the current invocation graph vertex has already -- been visited. - if Is_Visited (Curr_IGV_Id) then + if IGV_Sets.Contains (Visited_Invokers, Invoker) then return; end if; - Set_Is_Visited (Curr_IGV_Id); + IGV_Sets.Insert (Visited_Invokers, Invoker); -- Update the statistics @@ -287,10 +260,10 @@ package body Bindo.Augmentors is -- indicates that elaboration is transitioning from one unit to -- another. Add a library graph edge to capture this dependency. - Curr_LGV_Id := Lib_Vertex (Inv_Graph, Curr_IGV_Id); - pragma Assert (Present (Curr_LGV_Id)); + Invoker_Vertex := Body_Vertex (Inv_Graph, Invoker); + pragma Assert (Present (Invoker_Vertex)); - if Curr_LGV_Id /= Last_LGV_Id then + if Invoker_Vertex /= Last_Vertex then -- The path ultimately reaches back into the unit where the root -- resides, resulting in a self dependency. In most cases this is @@ -299,7 +272,9 @@ package body Bindo.Augmentors is -- library graph edge because the circularity is the result of -- expansion and thus spurious. - if Curr_LGV_Id = Root_LGV_Id and then Internal_Ctrl then + if Invoker_Vertex = Root_Vertex + and then Internal_Controlled_Action + then null; -- Otherwise create the library graph edge, even if this results @@ -307,33 +282,36 @@ package body Bindo.Augmentors is else Add_Edge - (G => Lib_Graph, - Pred => Curr_LGV_Id, - Succ => Root_LGV_Id, - Kind => Invocation_Edge); + (G => Lib_Graph, + Pred => Invoker_Vertex, + Succ => Root_Vertex, + Kind => Invocation_Edge, + Activates_Task => Activates_Task); end if; end if; -- Extend the DFS traversal to all targets of the invocation graph -- vertex. - Iter := Iterate_Edges_To_Targets (Inv_Graph, Curr_IGV_Id); + Iter := Iterate_Edges_To_Targets (Inv_Graph, Invoker); while Has_Next (Iter) loop - Next (Iter, IGE_Id); - pragma Assert (Present (IGE_Id)); - - Targ := Target (Inv_Graph, IGE_Id); - pragma Assert (Present (Targ)); + Next (Iter, Edge); + Edge_Kind := Kind (Inv_Graph, Edge); Visit_Vertex - (Curr_IGV_Id => Targ, - Last_LGV_Id => Curr_LGV_Id, - Root_LGV_Id => Root_LGV_Id, - Internal_Ctrl => - Internal_Ctrl - or else Kind (Inv_Graph, IGE_Id) in - Internal_Controlled_Invocation_Kind, - Path => New_Path); + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Invoker => Target (Inv_Graph, Edge), + Last_Vertex => Invoker_Vertex, + Root_Vertex => Root_Vertex, + Visited_Invokers => Visited_Invokers, + Activates_Task => + Activates_Task + or else Edge_Kind = Task_Activation, + Internal_Controlled_Action => + Internal_Controlled_Action + or else Edge_Kind in Internal_Controlled_Invocation_Kind, + Path => New_Path); end loop; end Visit_Vertex; diff --git a/gcc/ada/bindo-augmentors.ads b/gcc/ada/bindo-augmentors.ads index de6317c..c00d5c0 100644 --- a/gcc/ada/bindo-augmentors.ads +++ b/gcc/ada/bindo-augmentors.ads @@ -43,10 +43,10 @@ package Bindo.Augmentors is package Library_Graph_Augmentors is procedure Augment_Library_Graph - (Inv_G : Invocation_Graph; - Lib_G : Library_Graph); - -- Augment library graph Lib_G with information from invocation graph - -- Inv_G as follows: + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph); + -- Augment library graph Lib_Graph with information from invocation + -- graph Inv_Graph as follows: -- -- 1) Traverse the invocation graph starting from each elaboration -- procedure of unit Root. diff --git a/gcc/ada/bindo-builders.adb b/gcc/ada/bindo-builders.adb index c0340c0..9919007 100644 --- a/gcc/ada/bindo-builders.adb +++ b/gcc/ada/bindo-builders.adb @@ -25,12 +25,22 @@ with Binderr; use Binderr; with Butil; use Butil; +with Debug; use Debug; with Opt; use Opt; with Output; use Output; with Types; use Types; with Bindo.Units; use Bindo.Units; +with Bindo.Validators; +use Bindo.Validators; +use Bindo.Validators.Invocation_Graph_Validators; +use Bindo.Validators.Library_Graph_Validators; + +with Bindo.Writers; +use Bindo.Writers; +use Bindo.Writers.Phase_Writers; + with GNAT; use GNAT; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; @@ -64,10 +74,10 @@ package body Bindo.Builders is procedure Create_Vertex (IC_Id : Invocation_Construct_Id; - LGV_Id : Library_Graph_Vertex_Id); + Vertex : Library_Graph_Vertex_Id); pragma Inline (Create_Vertex); -- Create a new vertex for invocation construct IC_Id in invocation - -- graph Inv_Graph. The vertex is linked to vertex LGV_Id of library + -- graph Inv_Graph. The vertex is linked to vertex Vertex of library -- graph Lib_Graph. procedure Create_Vertices (U_Id : Unit_Id); @@ -75,6 +85,14 @@ package body Bindo.Builders is -- Create new vertices for all invocation constructs of unit U_Id in -- invocation graph Inv_Graph. + function Declaration_Placement_Vertex + (Vertex : Library_Graph_Vertex_Id; + Placement : Declaration_Placement_Kind) + return Library_Graph_Vertex_Id; + pragma Inline (Declaration_Placement_Vertex); + -- Obtain the spec or body of vertex Vertex depending on the requested + -- placement in Placement. + ---------------------------- -- Build_Invocation_Graph -- ---------------------------- @@ -85,16 +103,22 @@ package body Bindo.Builders is begin pragma Assert (Present (Lib_G)); + Start_Phase (Invocation_Graph_Construction); + -- Prepare the global data Inv_Graph := - Create (Initial_Vertices => Number_Of_Elaborable_Units, - Initial_Edges => Number_Of_Elaborable_Units); + Create + (Initial_Vertices => Number_Of_Elaborable_Units, + Initial_Edges => Number_Of_Elaborable_Units); Lib_Graph := Lib_G; For_Each_Elaborable_Unit (Create_Vertices'Access); For_Each_Elaborable_Unit (Create_Edges'Access); + Validate_Invocation_Graph (Inv_Graph); + End_Phase (Invocation_Graph_Construction); + return Inv_Graph; end Build_Invocation_Graph; @@ -107,33 +131,24 @@ package body Bindo.Builders is pragma Assert (Present (Lib_Graph)); pragma Assert (Present (IR_Id)); - IR_Rec : Invocation_Relation_Record renames - Invocation_Relations.Table (IR_Id); + Invoker_Sig : constant Invocation_Signature_Id := Invoker (IR_Id); + Target_Sig : constant Invocation_Signature_Id := Target (IR_Id); - pragma Assert (Present (IR_Rec.Invoker)); - pragma Assert (Present (IR_Rec.Target)); - - Invoker : Invocation_Graph_Vertex_Id; - Target : Invocation_Graph_Vertex_Id; + pragma Assert (Present (Invoker_Sig)); + pragma Assert (Present (Target_Sig)); begin -- Nothing to do when the target denotes an invocation construct that -- resides in a unit which will never be elaborated. - if not Needs_Elaboration (IR_Rec.Target) then + if not Needs_Elaboration (Target_Sig) then return; end if; - Invoker := Corresponding_Vertex (Inv_Graph, IR_Rec.Invoker); - Target := Corresponding_Vertex (Inv_Graph, IR_Rec.Target); - - pragma Assert (Present (Invoker)); - pragma Assert (Present (Target)); - Add_Edge (G => Inv_Graph, - Source => Invoker, - Target => Target, + Source => Corresponding_Vertex (Inv_Graph, Invoker_Sig), + Target => Corresponding_Vertex (Inv_Graph, Target_Sig), IR_Id => IR_Id); end Create_Edge; @@ -162,35 +177,25 @@ package body Bindo.Builders is procedure Create_Vertex (IC_Id : Invocation_Construct_Id; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id) is + begin pragma Assert (Present (Inv_Graph)); pragma Assert (Present (Lib_Graph)); pragma Assert (Present (IC_Id)); - pragma Assert (Present (LGV_Id)); - - IC_Rec : Invocation_Construct_Record renames - Invocation_Constructs.Table (IC_Id); - - Body_LGV_Id : Library_Graph_Vertex_Id; - - begin - -- Determine the proper library graph vertex which holds the body of - -- the invocation construct. - - if IC_Rec.Placement = In_Body then - Body_LGV_Id := Proper_Body (Lib_Graph, LGV_Id); - else - pragma Assert (IC_Rec.Placement = In_Spec); - Body_LGV_Id := Proper_Spec (Lib_Graph, LGV_Id); - end if; - - pragma Assert (Present (Body_LGV_Id)); + pragma Assert (Present (Vertex)); Add_Vertex - (G => Inv_Graph, - IC_Id => IC_Id, - LGV_Id => Body_LGV_Id); + (G => Inv_Graph, + IC_Id => IC_Id, + Body_Vertex => + Declaration_Placement_Vertex + (Vertex => Vertex, + Placement => Body_Placement (IC_Id)), + Spec_Vertex => + Declaration_Placement_Vertex + (Vertex => Vertex, + Placement => Spec_Placement (IC_Id))); end Create_Vertex; --------------------- @@ -203,18 +208,37 @@ package body Bindo.Builders is pragma Assert (Present (U_Id)); U_Rec : Unit_Record renames ALI.Units.Table (U_Id); - LGV_Id : constant Library_Graph_Vertex_Id := + Vertex : constant Library_Graph_Vertex_Id := Corresponding_Vertex (Lib_Graph, U_Id); - pragma Assert (Present (LGV_Id)); - begin for IC_Id in U_Rec.First_Invocation_Construct .. U_Rec.Last_Invocation_Construct loop - Create_Vertex (IC_Id, LGV_Id); + Create_Vertex (IC_Id, Vertex); end loop; end Create_Vertices; + + ---------------------------------- + -- Declaration_Placement_Vertex -- + ---------------------------------- + + function Declaration_Placement_Vertex + (Vertex : Library_Graph_Vertex_Id; + Placement : Declaration_Placement_Kind) + return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Vertex)); + + if Placement = In_Body then + return Proper_Body (Lib_Graph, Vertex); + else + pragma Assert (Placement = In_Spec); + return Proper_Spec (Lib_Graph, Vertex); + end if; + end Declaration_Placement_Vertex; end Invocation_Graph_Builders; ---------------------------- @@ -235,7 +259,7 @@ package body Bindo.Builders is pragma Inline (Hash_Unit); -- Obtain the hash value of key U_Id - package UL is new Dynamic_Hash_Tables + package Unit_Line_Tables is new Dynamic_Hash_Tables (Key_Type => Unit_Id, Value_Type => Logical_Line_Number, No_Value => No_Line_Number, @@ -253,9 +277,10 @@ package body Bindo.Builders is Lib_Graph : Library_Graph := Library_Graphs.Nil; - Unit_To_Line : UL.Dynamic_Hash_Table := UL.Nil; + Unit_To_Line : Unit_Line_Tables.Dynamic_Hash_Table := + Unit_Line_Tables.Nil; -- The map of unit name -> line number, used to detect duplicate unit - -- names and report errors. + -- names in the forced-elaboration-order file and report errors. ----------------------- -- Local subprograms -- @@ -348,7 +373,7 @@ package body Bindo.Builders is begin pragma Assert (Present (U_Id)); - UL.Put (Unit_To_Line, U_Id, Line); + Unit_Line_Tables.Put (Unit_To_Line, U_Id, Line); end Add_Unit; ------------------------- @@ -357,18 +382,23 @@ package body Bindo.Builders is function Build_Library_Graph return Library_Graph is begin + Start_Phase (Library_Graph_Construction); + -- Prepare the global data Lib_Graph := - Create (Initial_Vertices => Number_Of_Elaborable_Units, - Initial_Edges => Number_Of_Elaborable_Units); + Create + (Initial_Vertices => Number_Of_Elaborable_Units, + Initial_Edges => Number_Of_Elaborable_Units); For_Each_Elaborable_Unit (Create_Vertex'Access); For_Each_Elaborable_Unit (Create_Spec_And_Body_Edge'Access); For_Each_Elaborable_Unit (Create_With_Edges'Access); - Create_Forced_Edges; + Validate_Library_Graph (Lib_Graph); + End_Phase (Library_Graph_Construction); + return Lib_Graph; end Build_Library_Graph; @@ -383,14 +413,11 @@ package body Bindo.Builders is pragma Assert (Present (Pred)); pragma Assert (Present (Succ)); - Pred_LGV_Id : constant Library_Graph_Vertex_Id := + Pred_Vertex : constant Library_Graph_Vertex_Id := Corresponding_Vertex (Lib_Graph, Pred); - Succ_LGV_Id : constant Library_Graph_Vertex_Id := + Succ_Vertex : constant Library_Graph_Vertex_Id := Corresponding_Vertex (Lib_Graph, Succ); - pragma Assert (Present (Pred_LGV_Id)); - pragma Assert (Present (Succ_LGV_Id)); - begin Write_Unit_Name (Name (Pred)); Write_Str (" <-- "); @@ -398,10 +425,11 @@ package body Bindo.Builders is Write_Eol; Add_Edge - (G => Lib_Graph, - Pred => Pred_LGV_Id, - Succ => Succ_LGV_Id, - Kind => Forced_Edge); + (G => Lib_Graph, + Pred => Pred_Vertex, + Succ => Succ_Vertex, + Kind => Forced_Edge, + Activates_Task => False); end Create_Forced_Edge; ------------------------- @@ -409,15 +437,15 @@ package body Bindo.Builders is ------------------------- procedure Create_Forced_Edges is - Curr_Unit : Unit_Id; - Iter : Forced_Units_Iterator; - Prev_Unit : Unit_Id; - Unit_Line : Logical_Line_Number; - Unit_Name : Unit_Name_Type; + Current_Unit : Unit_Id; + Iter : Forced_Units_Iterator; + Previous_Unit : Unit_Id; + Unit_Line : Logical_Line_Number; + Unit_Name : Unit_Name_Type; begin - Prev_Unit := No_Unit_Id; - Unit_To_Line := UL.Create (20); + Previous_Unit := No_Unit_Id; + Unit_To_Line := Unit_Line_Tables.Create (20); -- Inspect the contents of the forced-elaboration-order file supplied -- to the binder using switch -f, and diagnose each unit accordingly. @@ -425,36 +453,35 @@ package body Bindo.Builders is Iter := Iterate_Forced_Units; while Has_Next (Iter) loop Next (Iter, Unit_Name, Unit_Line); - pragma Assert (Present (Unit_Name)); - Curr_Unit := Corresponding_Unit (Unit_Name); + Current_Unit := Corresponding_Unit (Unit_Name); - if not Present (Curr_Unit) then + if not Present (Current_Unit) then Missing_Unit_Info (Unit_Name); - elsif Is_Internal_Unit (Curr_Unit) then + elsif Is_Internal_Unit (Current_Unit) then Internal_Unit_Info (Unit_Name); - elsif Is_Duplicate_Unit (Curr_Unit) then - Duplicate_Unit_Error (Curr_Unit, Unit_Name, Unit_Line); + elsif Is_Duplicate_Unit (Current_Unit) then + Duplicate_Unit_Error (Current_Unit, Unit_Name, Unit_Line); -- Otherwise the unit is a valid candidate for a vertex. Create a -- forced edge between each pair of units. else - Add_Unit (Curr_Unit, Unit_Line); + Add_Unit (Current_Unit, Unit_Line); - if Present (Prev_Unit) then + if Present (Previous_Unit) then Create_Forced_Edge - (Pred => Prev_Unit, - Succ => Curr_Unit); + (Pred => Previous_Unit, + Succ => Current_Unit); end if; - Prev_Unit := Curr_Unit; + Previous_Unit := Current_Unit; end if; end loop; - UL.Destroy (Unit_To_Line); + Unit_Line_Tables.Destroy (Unit_To_Line); end Create_Forced_Edges; ------------------------------- @@ -462,42 +489,38 @@ package body Bindo.Builders is ------------------------------- procedure Create_Spec_And_Body_Edge (U_Id : Unit_Id) is - Aux_LGV_Id : Library_Graph_Vertex_Id; - LGV_Id : Library_Graph_Vertex_Id; + Extra_Vertex : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; begin pragma Assert (Present (Lib_Graph)); pragma Assert (Present (U_Id)); - LGV_Id := Corresponding_Vertex (Lib_Graph, U_Id); - pragma Assert (Present (LGV_Id)); + Vertex := Corresponding_Vertex (Lib_Graph, U_Id); -- The unit denotes a body that completes a previous spec. Link the -- spec and body. Add an edge between the predecessor spec and the -- successor body. - if Is_Body_With_Spec (Lib_Graph, LGV_Id) then - Aux_LGV_Id := + if Is_Body_With_Spec (Lib_Graph, Vertex) then + Extra_Vertex := Corresponding_Vertex (Lib_Graph, Corresponding_Spec (U_Id)); - pragma Assert (Present (Aux_LGV_Id)); - - Set_Corresponding_Item (Lib_Graph, LGV_Id, Aux_LGV_Id); + Set_Corresponding_Item (Lib_Graph, Vertex, Extra_Vertex); Add_Edge - (G => Lib_Graph, - Pred => Aux_LGV_Id, - Succ => LGV_Id, - Kind => Spec_Before_Body_Edge); + (G => Lib_Graph, + Pred => Extra_Vertex, + Succ => Vertex, + Kind => Spec_Before_Body_Edge, + Activates_Task => False); -- The unit denotes a spec with a completing body. Link the spec and -- body. - elsif Is_Spec_With_Body (Lib_Graph, LGV_Id) then - Aux_LGV_Id := + elsif Is_Spec_With_Body (Lib_Graph, Vertex) then + Extra_Vertex := Corresponding_Vertex (Lib_Graph, Corresponding_Body (U_Id)); - pragma Assert (Present (Aux_LGV_Id)); - - Set_Corresponding_Item (Lib_Graph, LGV_Id, Aux_LGV_Id); + Set_Corresponding_Item (Lib_Graph, Vertex, Extra_Vertex); end if; end Create_Spec_And_Body_Edge; @@ -531,11 +554,8 @@ package body Bindo.Builders is Withed_U_Id : constant Unit_Id := Corresponding_Unit (Withed_Rec.Uname); - pragma Assert (Present (Withed_U_Id)); - - Aux_LGV_Id : Library_Graph_Vertex_Id; Kind : Library_Graph_Edge_Kind; - Withed_LGV_Id : Library_Graph_Vertex_Id; + Withed_Vertex : Library_Graph_Vertex_Id; begin -- Nothing to do when the withed unit does not need to be elaborated. @@ -545,34 +565,39 @@ package body Bindo.Builders is return; end if; - Withed_LGV_Id := Corresponding_Vertex (Lib_Graph, Withed_U_Id); - pragma Assert (Present (Withed_LGV_Id)); + Withed_Vertex := Corresponding_Vertex (Lib_Graph, Withed_U_Id); - -- The with comes with pragma Elaborate + -- The with comes with pragma Elaborate. Treat the edge as a with + -- edge when switch -d_e (ignore the effects of pragma Elaborate) + -- is in effect. - if Withed_Rec.Elaborate then + if Withed_Rec.Elaborate + and then not Debug_Flag_Underscore_E + then Kind := Elaborate_Edge; -- The withed unit is a spec with a completing body. Add an edge -- between the body of the withed predecessor and the withing -- successor. - if Is_Spec_With_Body (Lib_Graph, Withed_LGV_Id) then - Aux_LGV_Id := - Corresponding_Vertex - (Lib_Graph, Corresponding_Body (Withed_U_Id)); - pragma Assert (Present (Aux_LGV_Id)); - + if Is_Spec_With_Body (Lib_Graph, Withed_Vertex) then Add_Edge - (G => Lib_Graph, - Pred => Aux_LGV_Id, - Succ => Succ, - Kind => Kind); + (G => Lib_Graph, + Pred => + Corresponding_Vertex + (Lib_Graph, Corresponding_Body (Withed_U_Id)), + Succ => Succ, + Kind => Kind, + Activates_Task => False); end if; - -- The with comes with pragma Elaborate_All + -- The with comes with pragma Elaborate_All. Treat the edge as a with + -- edge when switch -d_a (ignore the effects of pragma Elaborate_All) + -- is in effect. - elsif Withed_Rec.Elaborate_All then + elsif Withed_Rec.Elaborate_All + and then not Debug_Flag_Underscore_A + then Kind := Elaborate_All_Edge; -- Otherwise this is a regular with @@ -585,10 +610,11 @@ package body Bindo.Builders is -- successor. Add_Edge - (G => Lib_Graph, - Pred => Withed_LGV_Id, - Succ => Succ, - Kind => Kind); + (G => Lib_Graph, + Pred => Withed_Vertex, + Succ => Succ, + Kind => Kind, + Activates_Task => False); end Create_With_Edge; ----------------------- @@ -596,18 +622,13 @@ package body Bindo.Builders is ----------------------- procedure Create_With_Edges (U_Id : Unit_Id) is - LGV_Id : Library_Graph_Vertex_Id; - begin pragma Assert (Present (Lib_Graph)); pragma Assert (Present (U_Id)); - LGV_Id := Corresponding_Vertex (Lib_Graph, U_Id); - pragma Assert (Present (LGV_Id)); - Create_With_Edges (U_Id => U_Id, - Succ => LGV_Id); + Succ => Corresponding_Vertex (Lib_Graph, U_Id)); end Create_With_Edges; ----------------------- @@ -655,7 +676,7 @@ package body Bindo.Builders is pragma Assert (Present (Nam)); Prev_Line : constant Logical_Line_Number := - UL.Get (Unit_To_Line, U_Id); + Unit_Line_Tables.Get (Unit_To_Line, U_Id); begin Error_Msg_Nat_1 := Nat (Line); @@ -698,7 +719,7 @@ package body Bindo.Builders is begin pragma Assert (Present (U_Id)); - return UL.Contains (Unit_To_Line, U_Id); + return Unit_Line_Tables.Contains (Unit_To_Line, U_Id); end Is_Duplicate_Unit; ------------------------- diff --git a/gcc/ada/bindo-diagnostics.adb b/gcc/ada/bindo-diagnostics.adb index bf11d39..6f19ac0 100644 --- a/gcc/ada/bindo-diagnostics.adb +++ b/gcc/ada/bindo-diagnostics.adb @@ -23,50 +23,1533 @@ -- -- ------------------------------------------------------------------------------ +with Binderr; use Binderr; +with Debug; use Debug; +with Restrict; use Restrict; +with Rident; use Rident; +with Types; use Types; + +with Bindo.Validators; +use Bindo.Validators; +use Bindo.Validators.Cycle_Validators; + +with Bindo.Writers; +use Bindo.Writers; +use Bindo.Writers.Cycle_Writers; +use Bindo.Writers.Phase_Writers; + package body Bindo.Diagnostics is ----------------------- - -- Cycle_Diagnostics -- + -- Local subprograms -- + ----------------------- + + procedure Diagnose_All_Cycles + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph); + pragma Inline (Diagnose_All_Cycles); + -- Emit diagnostics for all cycles of library graph G + + procedure Diagnose_Cycle + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Cycle : Library_Graph_Cycle_Id); + pragma Inline (Diagnose_Cycle); + -- Emit diagnostics for cycle Cycle of library graph G + + procedure Find_And_Output_Invocation_Paths + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Source : Library_Graph_Vertex_Id; + Destination : Library_Graph_Vertex_Id); + pragma Inline (Find_And_Output_Invocation_Paths); + -- Find all paths in invocation graph Inv_Graph that originate from vertex + -- Source and reach vertex Destination of library graph Lib_Graph. Output + -- the transitions of each such path. + + function Find_Elaboration_Root + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Invocation_Graph_Vertex_Id; + pragma Inline (Find_Elaboration_Root); + -- Find the elaboration root in invocation graph Inv_Graph that corresponds + -- to vertex Vertex of library graph Lib_Graph. + + procedure Output_All_Cycles_Suggestions (G : Library_Graph); + pragma Inline (Output_All_Cycles_Suggestions); + -- Suggest the diagnostic of all cycles in library graph G if circumstances + -- allow it. + + procedure Output_Elaborate_All_Suggestions + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id); + pragma Inline (Output_Elaborate_All_Suggestions); + -- Suggest ways to break a cycle that involves an Elaborate_All edge that + -- links predecessor Pred and successor Succ of library graph G. + + procedure Output_Elaborate_All_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id); + pragma Inline (Output_Elaborate_All_Transition); + -- Output a transition through an Elaborate_All edge of library graph G + -- with successor Source and predecessor Actual_Destination. Parameter + -- Expected_Destination denotes the predecessor as specified by the next + -- edge in a cycle. + + procedure Output_Elaborate_Body_Suggestions + (G : Library_Graph; + Succ : Library_Graph_Vertex_Id); + pragma Inline (Output_Elaborate_Body_Suggestions); + -- Suggest ways to break a cycle that involves an edge where successor Succ + -- is either a spec subject to pragma Elaborate_Body or the body of such a + -- spec. + + procedure Output_Elaborate_Body_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean); + pragma Inline (Output_Elaborate_Body_Transition); + -- Output a transition through an edge of library graph G with successor + -- Source and predecessor Actual_Destination. Vertex Source is either + -- a spec subject to pragma Elaborate_Body or denotes the body of such + -- a spec. Expected_Destination denotes the predecessor as specified by + -- the next edge in a cycle. Elaborate_All_Active should be set when the + -- transition occurs within a cycle that involves an Elaborate_All edge. + + procedure Output_Elaborate_Suggestions + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id); + pragma Inline (Output_Elaborate_Suggestions); + -- Suggest ways to break a cycle that involves an Elaborate edge that links + -- predecessor Pred and successor Succ of library graph G. + + procedure Output_Elaborate_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id); + pragma Inline (Output_Elaborate_Transition); + -- Output a transition through an Elaborate edge of library graph G + -- with successor Source and predecessor Actual_Destination. Parameter + -- Expected_Destination denotes the predecessor as specified by the next + -- edge in a cycle. + + procedure Output_Forced_Suggestions + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id); + pragma Inline (Output_Forced_Suggestions); + -- Suggest ways to break a cycle that involves a Forced edge that links + -- predecessor Pred with successor Succ of library graph G. + + procedure Output_Forced_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean); + pragma Inline (Output_Forced_Transition); + -- Output a transition through a Forced edge of library graph G with + -- successor Source and predecessor Actual_Destination. Parameter + -- Expected_Destination denotes the predecessor as specified by the + -- next edge in a cycle. Elaborate_All_Active should be set when the + -- transition occurs within a cycle that involves an Elaborate_All edge. + + procedure Output_Full_Encoding_Suggestions + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + First_Edge : Library_Graph_Edge_Id); + pragma Inline (Output_Full_Encoding_Suggestions); + -- Suggest the use of the full path invocation graph encoding to break + -- cycle Cycle with initial edge First_Edge of library graph G. + + procedure Output_Invocation_Path + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Elaborated_Vertex : Library_Graph_Vertex_Id; + Path : IGE_Lists.Doubly_Linked_List; + Path_Id : in out Nat); + pragma Inline (Output_Invocation_Path); + -- Output path Path, which consists of invocation graph Inv_Graph edges. + -- Elaborated_Vertex is the vertex of library graph Lib_Graph whose + -- elaboration initiated the path. Path_Id is the unique id of the path. + + procedure Output_Invocation_Path_Transition + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Edge : Invocation_Graph_Edge_Id); + pragma Inline (Output_Invocation_Path_Transition); + -- Output a transition through edge Edge of invocation graph G, which is + -- part of an invocation path. Lib_Graph is the related library graph. + + procedure Output_Invocation_Related_Suggestions + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id); + pragma Inline (Output_Invocation_Related_Suggestions); + -- Suggest ways to break cycle Cycle of library graph G that involves at + -- least one invocation edge. + + procedure Output_Invocation_Transition + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Source : Library_Graph_Vertex_Id; + Destination : Library_Graph_Vertex_Id); + pragma Inline (Output_Invocation_Transition); + -- Output a transition through an invocation edge of library graph G with + -- successor Source and predecessor Destination. Inv_Graph is the related + -- invocation graph. + + procedure Output_Reason_And_Circularity_Header + (G : Library_Graph; + First_Edge : Library_Graph_Edge_Id); + pragma Inline (Output_Reason_And_Circularity_Header); + -- Output the reason and circularity header for a circularity of library + -- graph G with initial edge First_Edge. + + procedure Output_Suggestions + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + First_Edge : Library_Graph_Edge_Id); + pragma Inline (Output_Suggestions); + -- Suggest various ways to break cycle Cycle with initial edge First_Edge + -- of library graph G. + + procedure Output_Transition + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Current_Edge : Library_Graph_Edge_Id; + Next_Edge : Library_Graph_Edge_Id; + Elaborate_All_Active : Boolean); + pragma Inline (Output_Transition); + -- Output a transition described by edge Current_Edge, which is followed by + -- edge Next_Edge of library graph Lib_Graph. Inv_Graph denotes the related + -- invocation graph. Elaborate_All_Active should be set when the transition + -- occurs within a cycle that involves an Elaborate_All edge. + + procedure Output_With_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean); + pragma Inline (Output_With_Transition); + -- Output a transition through a regular with edge of library graph G + -- with successor Source and predecessor Actual_Destination. Parameter + -- Expected_Destination denotes the predecessor as specified by the next + -- edge in a cycle. Elaborate_All_Active should be set when the transition + -- occurs within a cycle that involves an Elaborate_All edge. + + procedure Visit_Vertex + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Invoker : Invocation_Graph_Vertex_Id; + Invoker_Vertex : Library_Graph_Vertex_Id; + Last_Vertex : Library_Graph_Vertex_Id; + Elaborated_Vertex : Library_Graph_Vertex_Id; + End_Vertex : Library_Graph_Vertex_Id; + Visited_Invokers : IGV_Sets.Membership_Set; + Path : IGE_Lists.Doubly_Linked_List; + Path_Id : in out Nat); + pragma Inline (Visit_Vertex); + -- Visit invocation graph vertex Invoker that resides in library graph + -- vertex Invoker_Vertex as part of a DFS traversal. Last_Vertex denotes + -- the previous vertex in the traversal. Elaborated_Vertex is the vertex + -- whose elaboration started the traversal. End_Vertex is the vertex that + -- terminates the traversal. Visited_Invoker is the set of all invokers + -- visited so far. All edges along the path are recorded in Path. Path_Id + -- is the id of the path. + + ------------------------- + -- Diagnose_All_Cycles -- + ------------------------- + + procedure Diagnose_All_Cycles + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph) + is + Cycle : Library_Graph_Cycle_Id; + Iter : All_Cycle_Iterator; + + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + + Iter := Iterate_All_Cycles (Lib_Graph); + while Has_Next (Iter) loop + Next (Iter, Cycle); + + Diagnose_Cycle + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Cycle => Cycle); + end loop; + end Diagnose_All_Cycles; + + ---------------------------- + -- Diagnose_Circularities -- + ---------------------------- + + procedure Diagnose_Circularities + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph) + is + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + + -- Find, validate, and output all cycles of the library graph + + Find_Cycles (Lib_Graph); + Validate_Cycles (Lib_Graph); + Write_Cycles (Lib_Graph); + + -- Diagnose all cycles in the graph regardless of their importance when + -- switch -d_C (diagnose all cycles) is in effect. + + if Debug_Flag_Underscore_CC then + Diagnose_All_Cycles (Inv_Graph, Lib_Graph); + + -- Otherwise diagnose the most important cycle in the graph + + else + Diagnose_Cycle + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Cycle => Highest_Precedence_Cycle (Lib_Graph)); + end if; + end Diagnose_Circularities; + + -------------------- + -- Diagnose_Cycle -- + -------------------- + + procedure Diagnose_Cycle + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Cycle : Library_Graph_Cycle_Id) + is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Cycle)); + + Elaborate_All_Active : constant Boolean := + Contains_Elaborate_All_Edge + (G => Lib_Graph, + Cycle => Cycle); + + Current_Edge : Library_Graph_Edge_Id; + First_Edge : Library_Graph_Edge_Id; + Iter : Edges_Of_Cycle_Iterator; + Next_Edge : Library_Graph_Edge_Id; + + begin + Start_Phase (Cycle_Diagnostics); + + First_Edge := No_Library_Graph_Edge; + + -- Inspect the edges of the cycle in pairs, emitting diagnostics based + -- on their successors and predecessors. + + Iter := Iterate_Edges_Of_Cycle (Lib_Graph, Cycle); + while Has_Next (Iter) loop + + -- Emit the reason for the cycle using the initial edge, which is the + -- most important edge in the cycle. + + if not Present (First_Edge) then + Next (Iter, Current_Edge); + + First_Edge := Current_Edge; + Output_Reason_And_Circularity_Header + (G => Lib_Graph, + First_Edge => First_Edge); + end if; + + -- Obtain the other edge of the pair + + exit when not Has_Next (Iter); + Next (Iter, Next_Edge); + + -- Describe the transition from the current edge to the next edge by + -- taking into account the predecessors and successors involved, as + -- well as the nature of the edge. + + Output_Transition + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Current_Edge => Current_Edge, + Next_Edge => Next_Edge, + Elaborate_All_Active => Elaborate_All_Active); + + Current_Edge := Next_Edge; + end loop; + + -- Describe the transition from the last edge to the first edge + + Output_Transition + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Current_Edge => Current_Edge, + Next_Edge => First_Edge, + Elaborate_All_Active => Elaborate_All_Active); + + -- Suggest various alternatives for breaking the cycle + + Output_Suggestions + (G => Lib_Graph, + Cycle => Cycle, + First_Edge => First_Edge); + + End_Phase (Cycle_Diagnostics); + end Diagnose_Cycle; + + -------------------------------------- + -- Find_And_Output_Invocation_Paths -- + -------------------------------------- + + procedure Find_And_Output_Invocation_Paths + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Source : Library_Graph_Vertex_Id; + Destination : Library_Graph_Vertex_Id) + is + Path : IGE_Lists.Doubly_Linked_List; + Path_Id : Nat; + Visited : IGV_Sets.Membership_Set; + + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Source)); + pragma Assert (Present (Destination)); + + -- Nothing to do when the invocation graph encoding format of the source + -- vertex does not contain detailed information about invocation paths. + + if Invocation_Graph_Encoding (Lib_Graph, Source) /= + Full_Path_Encoding + then + return; + end if; + + Path := IGE_Lists.Create; + Path_Id := 1; + Visited := IGV_Sets.Create (Number_Of_Vertices (Inv_Graph)); + + -- Start a DFS traversal over the invocation graph, in an attempt to + -- reach Destination from Source. The actual start of the path is the + -- elaboration root invocation vertex that corresponds to the Source. + -- Each unique path is emitted as part of the current cycle diagnostic. + + Visit_Vertex + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Invoker => + Find_Elaboration_Root + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Vertex => Source), + Invoker_Vertex => Source, + Last_Vertex => Source, + Elaborated_Vertex => Source, + End_Vertex => Destination, + Visited_Invokers => Visited, + Path => Path, + Path_Id => Path_Id); + + IGE_Lists.Destroy (Path); + IGV_Sets.Destroy (Visited); + end Find_And_Output_Invocation_Paths; + + --------------------------- + -- Find_Elaboration_Root -- + --------------------------- + + function Find_Elaboration_Root + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Invocation_Graph_Vertex_Id + is + Current_Vertex : Invocation_Graph_Vertex_Id; + Iter : Elaboration_Root_Iterator; + Root_Vertex : Invocation_Graph_Vertex_Id; + + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Vertex)); + + -- Assume that the vertex does not have a corresponding elaboration root + + Root_Vertex := No_Invocation_Graph_Vertex; + + -- Inspect all elaboration roots trying to find the one that resides in + -- the input vertex. + -- + -- IMPORTANT: + -- + -- * The iterator must run to completion in order to unlock the + -- invocation graph. + + Iter := Iterate_Elaboration_Roots (Inv_Graph); + while Has_Next (Iter) loop + Next (Iter, Current_Vertex); + + if not Present (Root_Vertex) + and then Body_Vertex (Inv_Graph, Current_Vertex) = Vertex + then + Root_Vertex := Current_Vertex; + end if; + end loop; + + return Root_Vertex; + end Find_Elaboration_Root; + + ----------------------------------- + -- Output_All_Cycles_Suggestions -- + ----------------------------------- + + procedure Output_All_Cycles_Suggestions (G : Library_Graph) is + begin + pragma Assert (Present (G)); + + -- The library graph contains at least one cycle and only the highest + -- priority cycle was diagnosed. Diagnosing all cycles may yield extra + -- information for decision making. + + if Number_Of_Cycles (G) > 1 and then not Debug_Flag_Underscore_CC then + Error_Msg_Info + (" diagnose all circularities (binder switch -d_C)"); + end if; + end Output_All_Cycles_Suggestions; + + -------------------------------------- + -- Output_Elaborate_All_Suggestions -- + -------------------------------------- + + procedure Output_Elaborate_All_Suggestions + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Error_Msg_Unit_1 := Name (G, Pred); + Error_Msg_Unit_2 := Name (G, Succ); + Error_Msg_Info + (" change pragma Elaborate_All for unit $ to Elaborate in unit $"); + Error_Msg_Info + (" remove pragma Elaborate_All for unit $ in unit $"); + end Output_Elaborate_All_Suggestions; + + ------------------------------------- + -- Output_Elaborate_All_Transition -- + ------------------------------------- + + procedure Output_Elaborate_All_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Source)); + pragma Assert (Present (Actual_Destination)); + pragma Assert (Present (Expected_Destination)); + + -- The actual and expected destination vertices match, and denote the + -- initial declaration of a unit. + -- + -- Elaborate_All Actual_Destination + -- Source ---------------> spec --> + -- Expected_Destination + -- + -- Elaborate_All Actual_Destination + -- Source ---------------> stand-alone body --> + -- Expected_Destination + + if Actual_Destination = Expected_Destination then + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause and pragma Elaborate_All for unit $"); + + -- Otherwise the actual destination vertex denotes the spec of a unit, + -- while the expected destination is the corresponding body. + -- + -- Elaborate_All Actual_Destination + -- Source ---------------> spec + -- + -- body --> + -- Expected_Destination + + else + pragma Assert (Is_Spec_With_Body (G, Actual_Destination)); + pragma Assert (Is_Body_With_Spec (G, Expected_Destination)); + pragma Assert + (Proper_Body (G, Actual_Destination) = Expected_Destination); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause and pragma Elaborate_All for unit $"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate_All"); + end if; + end Output_Elaborate_All_Transition; + + --------------------------------------- + -- Output_Elaborate_Body_Suggestions -- + --------------------------------------- + + procedure Output_Elaborate_Body_Suggestions + (G : Library_Graph; + Succ : Library_Graph_Vertex_Id) + is + Spec : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Succ)); + + -- Find the initial declaration of the unit because it is the one + -- subject to pragma Elaborate_Body. + + if Is_Body_With_Spec (G, Succ) then + Spec := Proper_Spec (G, Succ); + else + Spec := Succ; + end if; + + Error_Msg_Unit_1 := Name (G, Spec); + Error_Msg_Info + (" remove pragma Elaborate_Body in unit $"); + end Output_Elaborate_Body_Suggestions; + + -------------------------------------- + -- Output_Elaborate_Body_Transition -- + -------------------------------------- + + procedure Output_Elaborate_Body_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Source)); + pragma Assert (Present (Actual_Destination)); + pragma Assert (Present (Expected_Destination)); + + -- The actual and expected destination vertices match + -- + -- Actual_Destination + -- Source --------> spec --> + -- Elaborate_Body Expected_Destination + -- + -- spec + -- + -- Actual_Destination + -- Source --------> body --> + -- Elaborate_Body Expected_Destination + + if Actual_Destination = Expected_Destination then + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause for unit $"); + + -- The actual destination vertex denotes the spec of a unit while the + -- expected destination is the corresponding body, and the unit is in + -- the closure of an earlier Elaborate_All pragma. + -- + -- Actual_Destination + -- Source --------> spec + -- Elaborate_Body + -- body --> + -- Expected_Destination + + elsif Elaborate_All_Active then + pragma Assert (Is_Spec_With_Body (G, Actual_Destination)); + pragma Assert (Is_Body_With_Spec (G, Expected_Destination)); + pragma Assert + (Proper_Body (G, Actual_Destination) = Expected_Destination); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause for unit $"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate_All"); + + -- Otherwise the actual destination vertex is the spec of a unit subject + -- to pragma Elaborate_Body and the expected destination vertex is the + -- completion body. + -- + -- Actual_Destination + -- Source --------> spec Elaborate_Body + -- Elaborate_Body + -- body --> + -- Expected_Destination + + else + pragma Assert + (Is_Elaborate_Body_Pair + (G => G, + Spec_Vertex => Actual_Destination, + Body_Vertex => Expected_Destination)); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause for unit $"); + + Error_Msg_Unit_1 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ is subject to pragma Elaborate_Body"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate_Body"); + end if; + end Output_Elaborate_Body_Transition; + + ---------------------------------- + -- Output_Elaborate_Suggestions -- + ---------------------------------- + + procedure Output_Elaborate_Suggestions + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Error_Msg_Unit_1 := Name (G, Pred); + Error_Msg_Unit_2 := Name (G, Succ); + Error_Msg_Info + (" remove pragma Elaborate for unit $ in unit $"); + end Output_Elaborate_Suggestions; + + --------------------------------- + -- Output_Elaborate_Transition -- + --------------------------------- + + procedure Output_Elaborate_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id) + is + Spec : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Source)); + pragma Assert (Present (Actual_Destination)); + pragma Assert (Present (Expected_Destination)); + + -- The actual and expected destination vertices match, and denote the + -- initial declaration of a unit. + -- + -- Elaborate Actual_Destination + -- Source -----------> spec --> + -- Expected_Destination + -- + -- Elaborate Actual_Destination + -- Source -----------> stand-alone body --> + -- Expected_Destination + -- + -- The processing of pragma Elaborate body generates an edge between a + -- successor and predecessor body. + -- + -- spec + -- + -- Elaborate Actual_Destination + -- Source -----------> body --> + -- Expected_Destination + + if Actual_Destination = Expected_Destination then + + -- Find the initial declaration of the unit because it is the one + -- subject to pragma Elaborate. + + if Is_Body_With_Spec (G, Actual_Destination) then + Spec := Proper_Spec (G, Actual_Destination); + else + Spec := Actual_Destination; + end if; + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Spec); + Error_Msg_Info + (" unit $ has with clause and pragma Elaborate for unit $"); + + if Actual_Destination /= Spec then + Error_Msg_Unit_1 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate"); + end if; + + -- Otherwise the actual destination vertex denotes the spec of a unit + -- while the expected destination vertex is the corresponding body. + -- + -- Elaborate Actual_Destination + -- Source -----------> spec + -- + -- body --> + -- Expected_Destination + + else + pragma Assert (Is_Spec_With_Body (G, Actual_Destination)); + pragma Assert (Is_Body_With_Spec (G, Expected_Destination)); + pragma Assert + (Proper_Body (G, Actual_Destination) = Expected_Destination); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause and pragma Elaborate for unit $"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate"); + end if; + end Output_Elaborate_Transition; + + ------------------------------- + -- Output_Forced_Suggestions -- + ------------------------------- + + procedure Output_Forced_Suggestions + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Error_Msg_Unit_1 := Name (G, Succ); + Error_Msg_Unit_2 := Name (G, Pred); + Error_Msg_Info + (" remove the dependency of unit $ on unit $ from the argument of " + & "switch -f"); + Error_Msg_Info + (" remove switch -f"); + end Output_Forced_Suggestions; + + ------------------------------ + -- Output_Forced_Transition -- + ------------------------------ + + procedure Output_Forced_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Source)); + pragma Assert (Present (Actual_Destination)); + pragma Assert (Present (Expected_Destination)); + + -- The actual and expected destination vertices match + -- + -- Forced Actual_Destination + -- Source --------> spec --> + -- Expected_Destination + -- + -- Forced Actual_Destination + -- Source --------> body --> + -- Expected_Destination + + if Actual_Destination = Expected_Destination then + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has a dependency on unit $ forced by -f switch"); + + -- The actual destination vertex denotes the spec of a unit while the + -- expected destination is the corresponding body, and the unit is in + -- the closure of an earlier Elaborate_All pragma. + -- + -- Forced Actual_Destination + -- Source --------> spec + -- + -- body --> + -- Expected_Destination + + elsif Elaborate_All_Active then + pragma Assert (Is_Spec_With_Body (G, Actual_Destination)); + pragma Assert (Is_Body_With_Spec (G, Expected_Destination)); + pragma Assert + (Proper_Body (G, Actual_Destination) = Expected_Destination); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has a dependency on unit $ forced by -f switch"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate_All"); + + -- Otherwise the actual destination vertex denotes a spec subject to + -- pragma Elaborate_Body while the expected destination denotes the + -- corresponding body. + -- + -- Forced Actual_Destination + -- Source --------> spec Elaborate_Body + -- + -- body --> + -- Expected_Destination + + else + pragma Assert + (Is_Elaborate_Body_Pair + (G => G, + Spec_Vertex => Actual_Destination, + Body_Vertex => Expected_Destination)); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has a dependency on unit $ forced by -f switch"); + + Error_Msg_Unit_1 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ is subject to pragma Elaborate_Body"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate_Body"); + end if; + end Output_Forced_Transition; + + -------------------------------------- + -- Output_Full_Encoding_Suggestions -- + -------------------------------------- + + procedure Output_Full_Encoding_Suggestions + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + First_Edge : Library_Graph_Edge_Id) + is + Succ : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + pragma Assert (Present (First_Edge)); + + if Is_Invocation_Edge (G, First_Edge) then + Succ := Successor (G, First_Edge); + + if Invocation_Graph_Encoding (G, Succ) /= Full_Path_Encoding then + Error_Msg_Info + (" use detailed invocation information (compiler switch " + & "-gnatd_F)"); + end if; + end if; + end Output_Full_Encoding_Suggestions; + + ---------------------------- + -- Output_Invocation_Path -- + ----------------------------- + + procedure Output_Invocation_Path + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Elaborated_Vertex : Library_Graph_Vertex_Id; + Path : IGE_Lists.Doubly_Linked_List; + Path_Id : in out Nat) + is + Edge : Invocation_Graph_Edge_Id; + Iter : IGE_Lists.Iterator; + + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Elaborated_Vertex)); + pragma Assert (IGE_Lists.Present (Path)); + + Error_Msg_Nat_1 := Path_Id; + Error_Msg_Info (" path #:"); + + Error_Msg_Unit_1 := Name (Lib_Graph, Elaborated_Vertex); + Error_Msg_Info (" elaboration of unit $"); + + Iter := IGE_Lists.Iterate (Path); + while IGE_Lists.Has_Next (Iter) loop + IGE_Lists.Next (Iter, Edge); + + Output_Invocation_Path_Transition + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Edge => Edge); + end loop; + + Path_Id := Path_Id + 1; + end Output_Invocation_Path; + + --------------------------------------- + -- Output_Invocation_Path_Transition -- + --------------------------------------- + + procedure Output_Invocation_Path_Transition + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Edge : Invocation_Graph_Edge_Id) + is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Edge)); + + Declared : constant String := "declared at {:#:#"; + + Targ : constant Invocation_Graph_Vertex_Id := + Target (Inv_Graph, Edge); + Targ_Extra : constant Name_Id := + Extra (Inv_Graph, Edge); + Targ_Vertex : constant Library_Graph_Vertex_Id := + Spec_Vertex (Inv_Graph, Targ); + + begin + Error_Msg_Name_1 := Name (Inv_Graph, Targ); + Error_Msg_Nat_1 := Line (Inv_Graph, Targ); + Error_Msg_Nat_2 := Column (Inv_Graph, Targ); + Error_Msg_File_1 := File_Name (Lib_Graph, Targ_Vertex); + + case Kind (Inv_Graph, Edge) is + when Accept_Alternative => + Error_Msg_Info + (" selection of entry % " + & Declared); + + when Access_Taken => + Error_Msg_Info + (" aliasing of subprogram % " + & Declared); + + when Call => + Error_Msg_Info + (" call to subprogram % " + & Declared); + + when Controlled_Adjustment + | Internal_Controlled_Adjustment + => + Error_Msg_Name_1 := Targ_Extra; + Error_Msg_Info + (" adjustment actions for type % " + & Declared); + + when Controlled_Finalization + | Internal_Controlled_Finalization + => + Error_Msg_Name_1 := Targ_Extra; + Error_Msg_Info + (" finalization actions for type % " + & Declared); + + when Controlled_Initialization + | Internal_Controlled_Initialization + | Type_Initialization + => + Error_Msg_Name_1 := Targ_Extra; + Error_Msg_Info + (" initialization actions for type % " + & Declared); + + when Default_Initial_Condition_Verification => + Error_Msg_Name_1 := Targ_Extra; + Error_Msg_Info + (" verification of Default_Initial_Condition for type % " + & Declared); + + when Initial_Condition_Verification => + Error_Msg_Info + (" verification of Initial_Condition " + & Declared); + + when Instantiation => + Error_Msg_Info + (" instantiation % " + & Declared); + + when Invariant_Verification => + Error_Msg_Name_1 := Targ_Extra; + Error_Msg_Info + (" verification of invariant for type % " + & Declared); + + when Postcondition_Verification => + Error_Msg_Name_1 := Targ_Extra; + Error_Msg_Info + (" verification of postcondition for subprogram % " + & Declared); + + when Protected_Entry_Call => + Error_Msg_Info + (" call to protected entry % " + & Declared); + + when Protected_Subprogram_Call => + Error_Msg_Info + (" call to protected subprogram % " + & Declared); + + when Task_Activation => + Error_Msg_Info + (" activation of local task " + & Declared); + + when Task_Entry_Call => + Error_Msg_Info + (" call to task entry % " + & Declared); + + when others => + pragma Assert (False); + null; + end case; + end Output_Invocation_Path_Transition; + + ------------------------------------------- + -- Output_Invocation_Related_Suggestions -- + ------------------------------------------- + + procedure Output_Invocation_Related_Suggestions + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + -- Nothing to do when the cycle does not contain an invocation edge + + if Invocation_Edge_Count (G, Cycle) = 0 then + return; + end if; + + -- The cycle contains at least one invocation edge, where at least + -- one of the paths the edge represents activates a task. The use of + -- restriction No_Entry_Calls_In_Elaboration_Code may halt the flow + -- within the task body on a select or accept statement, eliminating + -- subsequent invocation edges, thus breaking the cycle. + + if not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) + and then Contains_Task_Activation (G, Cycle) + then + Error_Msg_Info + (" use pragma Restrictions " + & "(No_Entry_Calls_In_Elaboration_Code)"); + end if; + + -- The cycle contains at least one invocation edge where the successor + -- was statically elaborated. The use of the dynamic model may remove + -- one of the invocation edges in the cycle, thus breaking the cycle. + + if Contains_Static_Successor_Edge (G, Cycle) then + Error_Msg_Info + (" use the dynamic elaboration model (compiler switch -gnatE)"); + end if; + end Output_Invocation_Related_Suggestions; + + ---------------------------------- + -- Output_Invocation_Transition -- + ---------------------------------- + + procedure Output_Invocation_Transition + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Source : Library_Graph_Vertex_Id; + Destination : Library_Graph_Vertex_Id) + is + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Source)); + pragma Assert (Present (Destination)); + + Error_Msg_Unit_1 := Name (Lib_Graph, Source); + Error_Msg_Unit_2 := Name (Lib_Graph, Destination); + Error_Msg_Info + (" unit $ invokes a construct of unit $ at elaboration time"); + + Find_And_Output_Invocation_Paths + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Source => Source, + Destination => Destination); + end Output_Invocation_Transition; + + ------------------------------------------ + -- Output_Reason_And_Circularity_Header -- + ------------------------------------------ + + procedure Output_Reason_And_Circularity_Header + (G : Library_Graph; + First_Edge : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (First_Edge)); + + Succ : constant Library_Graph_Vertex_Id := Successor (G, First_Edge); + + begin + Error_Msg_Unit_1 := Name (G, Succ); + Error_Msg ("Elaboration circularity detected"); + Error_Msg_Info (""); + Error_Msg_Info (" Reason:"); + Error_Msg_Info (""); + Error_Msg_Info (" unit $ depends on its own elaboration"); + Error_Msg_Info (""); + Error_Msg_Info (" Circularity:"); + Error_Msg_Info (""); + end Output_Reason_And_Circularity_Header; + + ------------------------ + -- Output_Suggestions -- + ------------------------ + + procedure Output_Suggestions + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + First_Edge : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + pragma Assert (Present (First_Edge)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, First_Edge); + Succ : constant Library_Graph_Vertex_Id := Successor (G, First_Edge); + + begin + Error_Msg_Info (""); + Error_Msg_Info (" Suggestions:"); + Error_Msg_Info (""); + + -- Output edge-specific suggestions + + if Is_Elaborate_All_Edge (G, First_Edge) then + Output_Elaborate_All_Suggestions + (G => G, + Pred => Pred, + Succ => Succ); + + elsif Is_Elaborate_Body_Edge (G, First_Edge) then + Output_Elaborate_Body_Suggestions + (G => G, + Succ => Succ); + + elsif Is_Elaborate_Edge (G, First_Edge) then + Output_Elaborate_Suggestions + (G => G, + Pred => Pred, + Succ => Succ); + + elsif Is_Forced_Edge (G, First_Edge) then + Output_Forced_Suggestions + (G => G, + Pred => Pred, + Succ => Succ); + end if; + + -- Output general purpose suggestions + + Output_Invocation_Related_Suggestions + (G => G, + Cycle => Cycle); + + Output_Full_Encoding_Suggestions + (G => G, + Cycle => Cycle, + First_Edge => First_Edge); + + Output_All_Cycles_Suggestions (G); + + Error_Msg_Info (""); + end Output_Suggestions; + + ----------------------- + -- Output_Transition -- ----------------------- - package body Cycle_Diagnostics is + procedure Output_Transition + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Current_Edge : Library_Graph_Edge_Id; + Next_Edge : Library_Graph_Edge_Id; + Elaborate_All_Active : Boolean) + is + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Current_Edge)); + pragma Assert (Present (Next_Edge)); + + Actual_Destination : constant Library_Graph_Vertex_Id := + Predecessor (Lib_Graph, Current_Edge); + Expected_Destination : constant Library_Graph_Vertex_Id := + Successor (Lib_Graph, Next_Edge); + Source : constant Library_Graph_Vertex_Id := + Successor (Lib_Graph, Current_Edge); + + begin + if Is_Elaborate_All_Edge (Lib_Graph, Current_Edge) then + Output_Elaborate_All_Transition + (G => Lib_Graph, + Source => Source, + Actual_Destination => Actual_Destination, + Expected_Destination => Expected_Destination); + + elsif Is_Elaborate_Body_Edge (Lib_Graph, Current_Edge) then + Output_Elaborate_Body_Transition + (G => Lib_Graph, + Source => Source, + Actual_Destination => Actual_Destination, + Expected_Destination => Expected_Destination, + Elaborate_All_Active => Elaborate_All_Active); - ----------------------------- - -- Has_Elaborate_All_Cycle -- - ----------------------------- + elsif Is_Elaborate_Edge (Lib_Graph, Current_Edge) then + Output_Elaborate_Transition + (G => Lib_Graph, + Source => Source, + Actual_Destination => Actual_Destination, + Expected_Destination => Expected_Destination); - function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean is - Has_Cycle : Boolean; - Iter : All_Edge_Iterator; - LGE_Id : Library_Graph_Edge_Id; + elsif Is_Forced_Edge (Lib_Graph, Current_Edge) then + Output_Forced_Transition + (G => Lib_Graph, + Source => Source, + Actual_Destination => Actual_Destination, + Expected_Destination => Expected_Destination, + Elaborate_All_Active => Elaborate_All_Active); - begin - pragma Assert (Present (G)); + elsif Is_Invocation_Edge (Lib_Graph, Current_Edge) then + Output_Invocation_Transition + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Source => Source, + Destination => Expected_Destination); - -- Assume that the graph lacks a cycle + else + pragma Assert (Is_With_Edge (Lib_Graph, Current_Edge)); - Has_Cycle := False; + Output_With_Transition + (G => Lib_Graph, + Source => Source, + Actual_Destination => Actual_Destination, + Expected_Destination => Expected_Destination, + Elaborate_All_Active => Elaborate_All_Active); + end if; + end Output_Transition; - -- The library graph has an Elaborate_All cycle when one of its edges - -- represents a with clause for a unit with pragma Elaborate_All, and - -- both the predecessor and successor reside in the same component. - -- Note that the iteration must run to completion in order to unlock - -- the graph. + ---------------------------- + -- Output_With_Transition -- + ---------------------------- - Iter := Iterate_All_Edges (G); + procedure Output_With_Transition + (G : Library_Graph; + Source : Library_Graph_Vertex_Id; + Actual_Destination : Library_Graph_Vertex_Id; + Expected_Destination : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Source)); + pragma Assert (Present (Actual_Destination)); + pragma Assert (Present (Expected_Destination)); + + -- The actual and expected destination vertices match, and denote the + -- initial declaration of a unit. + -- + -- with Actual_Destination + -- Source ------> spec --> + -- Expected_Destination + -- + -- with Actual_Destination + -- Source ------> stand-alone body --> + -- Expected_Destination + + if Actual_Destination = Expected_Destination then + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause for unit $"); + + -- The actual destination vertex denotes the spec of a unit while the + -- expected destination is the corresponding body, and the unit is in + -- the closure of an earlier Elaborate_All pragma. + -- + -- with Actual_Destination + -- Source ------> spec + -- + -- body --> + -- Expected_Destination + + elsif Elaborate_All_Active then + pragma Assert (Is_Spec_With_Body (G, Actual_Destination)); + pragma Assert (Is_Body_With_Spec (G, Expected_Destination)); + pragma Assert + (Proper_Body (G, Actual_Destination) = Expected_Destination); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause for unit $"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate_All"); + + -- Otherwise the actual destination vertex denotes a spec subject to + -- pragma Elaborate_Body while the expected destination denotes the + -- corresponding body. + -- + -- with Actual_Destination + -- Source ------> spec Elaborate_Body + -- + -- body --> + -- Expected_Destination + + else + pragma Assert + (Is_Elaborate_Body_Pair + (G => G, + Spec_Vertex => Actual_Destination, + Body_Vertex => Expected_Destination)); + + Error_Msg_Unit_1 := Name (G, Source); + Error_Msg_Unit_2 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ has with clause for unit $"); + + Error_Msg_Unit_1 := Name (G, Actual_Destination); + Error_Msg_Info + (" unit $ is subject to pragma Elaborate_Body"); + + Error_Msg_Unit_1 := Name (G, Expected_Destination); + Error_Msg_Info + (" unit $ is in the closure of pragma Elaborate_Body"); + end if; + end Output_With_Transition; + + ------------------ + -- Visit_Vertex -- + ------------------ + + procedure Visit_Vertex + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Invoker : Invocation_Graph_Vertex_Id; + Invoker_Vertex : Library_Graph_Vertex_Id; + Last_Vertex : Library_Graph_Vertex_Id; + Elaborated_Vertex : Library_Graph_Vertex_Id; + End_Vertex : Library_Graph_Vertex_Id; + Visited_Invokers : IGV_Sets.Membership_Set; + Path : IGE_Lists.Doubly_Linked_List; + Path_Id : in out Nat) + is + Edge : Invocation_Graph_Edge_Id; + Iter : Edges_To_Targets_Iterator; + Targ : Invocation_Graph_Vertex_Id; + + begin + pragma Assert (Present (Inv_Graph)); + pragma Assert (Present (Lib_Graph)); + pragma Assert (Present (Invoker)); + pragma Assert (Present (Invoker_Vertex)); + pragma Assert (Present (Last_Vertex)); + pragma Assert (Present (Elaborated_Vertex)); + pragma Assert (Present (End_Vertex)); + pragma Assert (IGV_Sets.Present (Visited_Invokers)); + pragma Assert (IGE_Lists.Present (Path)); + + -- The current invocation vertex resides within the end library vertex. + -- Emit the path that started from some elaboration root and ultimately + -- reached the desired library vertex. + + if Body_Vertex (Inv_Graph, Invoker) = End_Vertex + and then Invoker_Vertex /= Last_Vertex + then + Output_Invocation_Path + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Elaborated_Vertex => Elaborated_Vertex, + Path => Path, + Path_Id => Path_Id); + + -- Otherwise extend the search for the end library vertex via all edges + -- to targets. + + elsif not IGV_Sets.Contains (Visited_Invokers, Invoker) then + + -- Prepare for invoker backtracking + + IGV_Sets.Insert (Visited_Invokers, Invoker); + + -- Extend the search via all edges to targets + + Iter := Iterate_Edges_To_Targets (Inv_Graph, Invoker); while Has_Next (Iter) loop - Next (Iter, LGE_Id); - pragma Assert (Present (LGE_Id)); - - if Kind (G, LGE_Id) = Elaborate_All_Edge - and then Links_Vertices_In_Same_Component (G, LGE_Id) - then - Has_Cycle := True; - end if; + Next (Iter, Edge); + + -- Prepare for edge backtracking + + IGE_Lists.Append (Path, Edge); + + -- The traversal proceeds through the library vertex that houses + -- the body of the target. + + Targ := Target (Inv_Graph, Edge); + + Visit_Vertex + (Inv_Graph => Inv_Graph, + Lib_Graph => Lib_Graph, + Invoker => Targ, + Invoker_Vertex => Body_Vertex (Inv_Graph, Targ), + Last_Vertex => Invoker_Vertex, + Elaborated_Vertex => Elaborated_Vertex, + End_Vertex => End_Vertex, + Visited_Invokers => Visited_Invokers, + Path => Path, + Path_Id => Path_Id); + + -- Backtrack the edge + + IGE_Lists.Delete_Last (Path); end loop; - return Has_Cycle; - end Has_Elaborate_All_Cycle; - end Cycle_Diagnostics; + -- Backtrack the invoker + + IGV_Sets.Delete (Visited_Invokers, Invoker); + end if; + end Visit_Vertex; end Bindo.Diagnostics; diff --git a/gcc/ada/bindo-diagnostics.ads b/gcc/ada/bindo-diagnostics.ads index 3b1d01c..3835a68 100644 --- a/gcc/ada/bindo-diagnostics.ads +++ b/gcc/ada/bindo-diagnostics.ads @@ -30,6 +30,7 @@ with Bindo.Graphs; use Bindo.Graphs; +use Bindo.Graphs.Invocation_Graphs; use Bindo.Graphs.Library_Graphs; package Bindo.Diagnostics is @@ -46,16 +47,15 @@ package Bindo.Diagnostics is Order_Has_Elaborate_All_Circularity, Order_OK); - ----------------------- - -- Cycle_Diagnostics -- - ----------------------- + --------- + -- API -- + --------- - package Cycle_Diagnostics is - function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean; - pragma Inline (Has_Elaborate_All_Cycle); - -- Determine whether library graph G contains a cycle where pragma - -- Elaborate_All appears within a component. - - end Cycle_Diagnostics; + procedure Diagnose_Circularities + (Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph); + pragma Inline (Diagnose_Circularities); + -- Diagnose all cycles of library graph Lib_Graph with matching invocation + -- graph Inv_Graph. end Bindo.Diagnostics; diff --git a/gcc/ada/bindo-elaborators.adb b/gcc/ada/bindo-elaborators.adb index b11598c..9e207e1 100644 --- a/gcc/ada/bindo-elaborators.adb +++ b/gcc/ada/bindo-elaborators.adb @@ -23,11 +23,10 @@ -- -- ------------------------------------------------------------------------------ -with Binderr; use Binderr; -with Butil; use Butil; -with Debug; use Debug; -with Output; use Output; -with Types; use Types; +with Butil; use Butil; +with Debug; use Debug; +with Output; use Output; +with Types; use Types; with Bindo.Augmentors; use Bindo.Augmentors; @@ -40,7 +39,6 @@ use Bindo.Builders.Library_Graph_Builders; with Bindo.Diagnostics; use Bindo.Diagnostics; -use Bindo.Diagnostics.Cycle_Diagnostics; with Bindo.Units; use Bindo.Units; @@ -48,20 +46,19 @@ use Bindo.Units; with Bindo.Validators; use Bindo.Validators; use Bindo.Validators.Elaboration_Order_Validators; -use Bindo.Validators.Invocation_Graph_Validators; -use Bindo.Validators.Library_Graph_Validators; with Bindo.Writers; use Bindo.Writers; use Bindo.Writers.ALI_Writers; +use Bindo.Writers.Dependency_Writers; use Bindo.Writers.Elaboration_Order_Writers; use Bindo.Writers.Invocation_Graph_Writers; use Bindo.Writers.Library_Graph_Writers; +use Bindo.Writers.Phase_Writers; use Bindo.Writers.Unit_Closure_Writers; with GNAT; use GNAT; with GNAT.Graphs; use GNAT.Graphs; -with GNAT.Sets; use GNAT.Sets; package body Bindo.Elaborators is @@ -78,86 +75,61 @@ package body Bindo.Elaborators is ---------------------------------------------- package body Invocation_And_Library_Graph_Elaborators is - Add_To_All_Candidates_Msg : aliased String := - "add vertex to all candidates"; - Add_To_Comp_Candidates_Msg : aliased String := - "add vertex to component candidates"; - - ----------- - -- Types -- - ----------- - - type String_Ptr is access all String; - - ----------------- - -- Visited set -- - ----------------- - - package VS is new Membership_Sets - (Element_Type => Library_Graph_Vertex_Id, - "=" => "=", - Hash => Hash_Library_Graph_Vertex); - use VS; ----------------------- -- Local subprograms -- ----------------------- - procedure Add_Vertex - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Set : Membership_Set; - Msg : String; - Step : Elaboration_Order_Step; - Indent : Indentation_Level); - pragma Inline (Add_Vertex); - -- Add vertex LGV_Id of library graph G to membership set Set. Msg is - -- a message emitted for tracing purposes. Step is the current step in - -- the elaboration order. Indent is the desired indentation level for - -- tracing. - - procedure Add_Vertex_If_Elaborable - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Set : Membership_Set; - Msg : String; - Step : Elaboration_Order_Step; - Indent : Indentation_Level); - pragma Inline (Add_Vertex_If_Elaborable); - -- Add vertex LGV_Id of library graph G to membership set Set if it can - -- be elaborated. Msg is a message emitted for tracing purposes. Step is - -- the current step in the elaboration order. Indent is the desired - -- indentation level for tracing. - - function Create_All_Candidates_Set - (G : Library_Graph; - Step : Elaboration_Order_Step) return Membership_Set; - pragma Inline (Create_All_Candidates_Set); - -- Collect all elaborable candidate vertices of library graph G in a - -- set. Step is the current step in the elaboration order. - - function Create_Component_Candidates_Set - (G : Library_Graph; - Comp : Component_Id; - Step : Elaboration_Order_Step) return Membership_Set; - pragma Inline (Create_Component_Candidates_Set); - -- Collect all elaborable candidate vertices that appear in component - -- Comp of library graph G in a set. Step is the current step in the - -- elaboration order. + procedure Create_Component_Vertex_Sets + (G : Library_Graph; + Comp : Component_Id; + Elaborable_Vertices : out LGV_Sets.Membership_Set; + Waiting_Vertices : out LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step); + pragma Inline (Create_Component_Vertex_Sets); + -- Split all vertices of component Comp of library graph G as follows: + -- + -- * Elaborable vertices are added to set Elaborable_Vertices. + -- + -- * Vertices that are still waiting on their predecessors to be + -- elaborated are added to set Waiting_Vertices. + -- + -- Step is the current step in the elaboration order. + + procedure Create_Vertex_Sets + (G : Library_Graph; + Elaborable_Vertices : out LGV_Sets.Membership_Set; + Waiting_Vertices : out LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step); + pragma Inline (Create_Vertex_Sets); + -- Split all vertices of library graph G as follows: + -- + -- * Elaborable vertices are added to set Elaborable_Vertices. + -- + -- * Vertices that are still waiting on their predecessors to be + -- elaborated are added to set Waiting_Vertices. + -- + -- Step is the current step in the elaboration order. procedure Elaborate_Component - (G : Library_Graph; - Comp : Component_Id; - All_Candidates : Membership_Set; - Remaining_Vertices : in out Natural; - Order : in out Unit_Id_Table; - Step : Elaboration_Order_Step); + (G : Library_Graph; + Comp : Component_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step); pragma Inline (Elaborate_Component); - -- Elaborate as many vertices as possible that appear in component - -- Comp of library graph G. All_Candidates is the set of all elaborable - -- vertices across the whole library graph. Remaining_Vertices is the - -- number of vertices that remain to be elaborated. Order denotes the - -- elaboration order. Step is the current step in the elaboration order. + -- Elaborate as many vertices as possible that appear in component Comp + -- of library graph G. The sets contain vertices arranged as follows: + -- + -- * All_Elaborable_Vertices - all elaborable vertices in the library + -- graph. + -- + -- * All_Waiting_Vertices - all vertices in the library graph that are + -- waiting on predecessors to be elaborated. + -- + -- Order is the elaboration order. Step denotes the current step in the + -- elaboration order. procedure Elaborate_Library_Graph (G : Library_Graph; @@ -168,78 +140,144 @@ package body Bindo.Elaborators is -- the elaboration order. Status is the condition of the elaboration -- order. - procedure Elaborate_Units_Common - (Use_Inv_Graph : Boolean; - Inv_Graph : out Invocation_Graph; - Lib_Graph : out Library_Graph; - Order : out Unit_Id_Table; - Status : out Elaboration_Order_Status); - pragma Inline (Elaborate_Units_Common); - -- Find the elaboration order of all units in the bind. Use_Inv_Graph - -- should be set when library graph Lib_Graph is to be augmented with - -- information from invocation graph Inv_Graph. Order is the elaboration - -- order. Status is the condition of the elaboration order. - - procedure Elaborate_Units_Dynamic (Order : out Unit_Id_Table); - pragma Inline (Elaborate_Units_Dynamic); - -- Find the elaboration order of all units in the bind using the dynamic - -- model. Order is the elaboration order. In the event where no ordering - -- is possible, this routine diagnoses the issue(s) and raises exception - -- Unrecoverable_Error. - - procedure Elaborate_Units_Static (Order : out Unit_Id_Table); - pragma Inline (Elaborate_Units_Static); - -- Find the elaboration order of all units in the bind using the static - -- model. Order is the elaboration order. In the event where no ordering - -- is possible, this routine diagnoses the issue(s) and raises exception - -- Unrecoverable_Error. - procedure Elaborate_Vertex - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - All_Candidates : Membership_Set; - Comp_Candidates : Membership_Set; - Remaining_Vertices : in out Natural; - Order : in out Unit_Id_Table; - Step : Elaboration_Order_Step; - Indent : Indentation_Level); + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Elaborable_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); pragma Inline (Elaborate_Vertex); - -- Elaborate vertex LGV_Id of library graph G by adding its unit to + -- Elaborate vertex Vertex of library graph G by adding its unit to -- elaboration order Order. The routine updates awaiting successors - -- where applicable. All_Candidates denotes the set of all elaborable - -- vertices across the whole library graph. Comp_Candidates is the set - -- of all elaborable vertices in the component of LGV_Id. Parameter - -- Remaining_Vertices denotes the number of vertices that remain to - -- be elaborated. Step is the current step in the elaboration order. + -- where applicable. The sets contain vertices arranged as follows: + -- + -- * All_Elaborable_Vertices - all elaborable vertices in the library + -- graph. + -- + -- * All_Waiting_Vertices - all vertices in the library graph that are + -- waiting on predecessors to be elaborated. + -- + -- * Comp_Elaborable_Vertices - all elaborable vertices found in the + -- component of Vertex. + -- + -- * Comp_Waiting_Vertices - all vertices found in the component of + -- Vertex that are still waiting on predecessors to be elaborated. + -- + -- Order denotes the elaboration order. Step is the current step in the + -- elaboration order. Indent denotes the desired indentation level for + -- tracing. + + function Find_Best_Elaborable_Vertex + (G : Library_Graph; + Set : LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) return Library_Graph_Vertex_Id; + pragma Inline (Find_Best_Elaborable_Vertex); + -- Find the best vertex of library graph G from membership set S that + -- can be elaborated. Step is the current step in the elaboration order. -- Indent is the desired indentation level for tracing. - function Find_Best_Candidate + function Find_Best_Vertex + (G : Library_Graph; + Set : LGV_Sets.Membership_Set; + Is_Suitable_Vertex : LGV_Predicate_Ptr; + Compare_Vertices : LGV_Comparator_Ptr; + Initial_Best_Msg : String; + Subsequent_Best_Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + return Library_Graph_Vertex_Id; + pragma Inline (Find_Best_Vertex); + -- Find the best vertex of library graph G from membership set S which + -- satisfies predicate Is_Suitable_Vertex and is preferred by comparator + -- Compare_Vertices. Initial_Best_Msg is emitted on the first candidate + -- vertex. Subsequent_Best_Msg is emitted whenever a better vertex is + -- discovered. Step is the current step in the elaboration order. Indent + -- is the desired indentation level for tracing. + + function Find_Best_Weakly_Elaborable_Vertex (G : Library_Graph; - Set : Membership_Set; + Set : LGV_Sets.Membership_Set; Step : Elaboration_Order_Step; Indent : Indentation_Level) return Library_Graph_Vertex_Id; - pragma Inline (Find_Best_Candidate); - -- Find the most suitable vertex of library graph G for elaboration from - -- membership set Set. Step denotes the current step in the elaboration + pragma Inline (Find_Best_Weakly_Elaborable_Vertex); + -- Find the best vertex of library graph G from membership set S that + -- can be weakly elaborated. Step is the current step in the elaboration -- order. Indent is the desired indentation level for tracing. - function Is_Better_Candidate + function Has_Elaborable_Body + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Has_Elaborable_Body); + -- Determine whether vertex Vertex of library graph G has a body that is + -- elaborable. It is assumed that the vertex has been elaborated. + + procedure Insert_Elaborable_Successor + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Insert_Elaborable_Successor); + -- Add elaborable successor Vertex of library graph G to membership set + -- Elaborable_Vertices and remove it from both All_Waiting_Vertices and + -- Comp_Waiting_Vertices. Msg is a message emitted for tracing purposes. + -- Step is the current step in the elaboration order. Indent denotes the + -- desired indentation level for tracing. + + procedure Insert_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Set : LGV_Sets.Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Insert_Vertex); + -- Add vertex Vertex of library graph G to membership set Set. Msg is + -- a message emitted for tracing purposes. Step is the current step in + -- the elaboration order. Indent is the desired indentation level for + -- tracing. + + function Is_Better_Elaborable_Vertex (G : Library_Graph; - Best_Candid : Library_Graph_Vertex_Id; - New_Candid : Library_Graph_Vertex_Id) return Boolean; - pragma Inline (Is_Better_Candidate); - -- Determine whether new candidate vertex New_Candid of library graph - -- G is a more suitable choice for elaboration compared to the current - -- best candidate Best_Candid. - - procedure Trace_Candidate_Vertices - (G : Library_Graph; - Set : Membership_Set; - Step : Elaboration_Order_Step); - pragma Inline (Trace_Candidate_Vertices); - -- Write the candidate vertices of library graph G present in membership - -- set Set to standard output. Formal Step denotes the current step in - -- the elaboration order. + Vertex : Library_Graph_Vertex_Id; + Compared_To : Library_Graph_Vertex_Id) return Precedence_Kind; + pragma Inline (Is_Better_Elaborable_Vertex); + -- Determine whether vertex Vertex of library graph G is a better choice + -- for elaboration compared to vertex Compared_To. + + function Is_Better_Weakly_Elaborable_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Compared_To : Library_Graph_Vertex_Id) return Precedence_Kind; + pragma Inline (Is_Better_Weakly_Elaborable_Vertex); + -- Determine whether vertex Vertex of library graph G is a better choice + -- for weak elaboration compared to vertex Compared_To. + + function Is_Suitable_Elaborable_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Suitable_Elaborable_Vertex); + -- Determine whether vertex Vertex of library graph G is suitable for + -- elaboration. + + function Is_Suitable_Weakly_Elaborable_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Suitable_Weakly_Elaborable_Vertex); + -- Determine whether vertex Vertex of library graph G is suitable for + -- weak elaboration. + + procedure Set_Unit_Elaboration_Positions (Order : Unit_Id_Table); + pragma Inline (Set_Unit_Elaboration_Positions); + -- Set the ALI.Units positions of all elaboration units in order Order procedure Trace_Component (G : Library_Graph; @@ -255,243 +293,214 @@ package body Bindo.Elaborators is pragma Inline (Trace_Step); -- Write current step Step of the elaboration order to standard output - procedure Trace_Unelaborated_Vertices - (G : Library_Graph; - Count : Natural; - Step : Elaboration_Order_Step); - pragma Inline (Trace_Unelaborated_Vertices); - -- Write the remaining unelaborated vertices of library graph G to - -- standard output. Count is the number of vertices that remain to - -- be elaborated. Step is the current step in the elaboration order. - procedure Trace_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Msg : String; Step : Elaboration_Order_Step; Indent : Indentation_Level); pragma Inline (Trace_Vertex); - -- Write elaboration-related information for vertex LGV_Id of library + -- Write elaboration-related information for vertex Vertex of library -- graph G to standard output, starting with message Msg. Step is the -- current step in the elaboration order. Indent denotes the desired -- indentation level for tracing. + procedure Trace_Vertices + (G : Library_Graph; + Set : LGV_Sets.Membership_Set; + Set_Msg : String; + Vertex_Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); + pragma Inline (Trace_Vertices); + -- Write the candidate vertices of library graph G present in membership + -- set Set to standard output, starting with message Set_Msg. Vertex_Msg + -- is the message emitted prior to each vertex. Step denotes the current + -- step in the elaboration order. Indent denotes the desired indentation + -- level for tracing. + procedure Update_Successor - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - Succ : Library_Graph_Vertex_Id; - All_Candidates : Membership_Set; - Comp_Candidates : Membership_Set; - Step : Elaboration_Order_Step; - Indent : Indentation_Level); + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Elaborable_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); pragma Inline (Update_Successor); - -- Notify successor vertex Succ of library graph G along with its - -- component that their predecessor Pred has just been elaborated. - -- This may cause new vertices to become elaborable, and thus be added - -- to one of the two sets. All_Candidates is the set of all elaborable - -- vertices across the whole library graph. Comp_Candidates is the set - -- of all elaborable vertices in the component of Pred. Step is the - -- current step in the elaboration order. Indent denotes the desired - -- indentation level for tracing. + -- Notify the successor of edge Edge of library graph G along with its + -- component that their predecessor has just been elaborated. This may + -- cause new vertices to become elaborable. The sets contain vertices + -- arranged as follows: + -- + -- * All_Elaborable_Vertices - all elaborable vertices in the library + -- graph. + -- + -- * All_Waiting_Vertices - all vertices in the library graph that are + -- waiting on predecessors to be elaborated. + -- + -- * Comp_Elaborable_Vertices - all elaborable vertices found in the + -- component of Vertex. + -- + -- * Comp_Waiting_Vertices - all vertices found in the component of + -- Vertex that are still waiting on predecessors to be elaborated. + -- + -- Step is the current step in the elaboration order. Indent denotes the + -- desired indentation level for tracing. procedure Update_Successors - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - All_Candidates : Membership_Set; - Comp_Candidates : Membership_Set; - Step : Elaboration_Order_Step; - Indent : Indentation_Level); + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Elaborable_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level); pragma Inline (Update_Successors); - -- Notify all successors along with their components that their - -- predecessor vertex Pred of ligrary graph G has just been elaborated. - -- This may cause new vertices to become elaborable, and thus be added - -- to one of the two sets. All_Candidates is the set of all elaborable - -- vertices across the whole library graph. Comp_Candidates is the set - -- of all elaborable vertices in the component of Pred. Step is the - -- current step in the elaboration order. Indent denotes the desired - -- indentation level for tracing. - - ---------------- - -- Add_Vertex -- - ---------------- - - procedure Add_Vertex - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Set : Membership_Set; - Msg : String; - Step : Elaboration_Order_Step; - Indent : Indentation_Level) - is - begin - pragma Assert (Present (LGV_Id)); - pragma Assert (Needs_Elaboration (G, LGV_Id)); - pragma Assert (Present (Set)); - - -- Add vertex only when it is not present in the set. This is not - -- strictly necessary because the set implementation handles this - -- case, however the check eliminates spurious traces. - - if not Contains (Set, LGV_Id) then - Trace_Vertex - (G => G, - LGV_Id => LGV_Id, - Msg => Msg, - Step => Step, - Indent => Indent); - - Insert (Set, LGV_Id); - end if; - end Add_Vertex; - - ------------------------------ - -- Add_Vertex_If_Elaborable -- - ------------------------------ - - procedure Add_Vertex_If_Elaborable - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Set : Membership_Set; - Msg : String; - Step : Elaboration_Order_Step; - Indent : Indentation_Level) + -- Notify all successors of vertex Vertex of library graph G along with + -- their components that their predecessor has just been elaborated. + -- This may cause new vertices to become elaborable. The sets contain + -- vertices arranged as follows: + -- + -- * All_Elaborable_Vertices - all elaborable vertices in the library + -- graph. + -- + -- * All_Waiting_Vertices - all vertices in the library graph that are + -- waiting on predecessors to be elaborated. + -- + -- * Comp_Elaborable_Vertices - all elaborable vertices found in the + -- component of Vertex. + -- + -- * Comp_Waiting_Vertices - all vertices found in the component of + -- Vertex that are still waiting on predecessors to be elaborated. + -- + -- Step is the current step in the elaboration order. Indent denotes the + -- desired indentation level for tracing. + + ---------------------------------- + -- Create_Component_Vertex_Sets -- + ---------------------------------- + + procedure Create_Component_Vertex_Sets + (G : Library_Graph; + Comp : Component_Id; + Elaborable_Vertices : out LGV_Sets.Membership_Set; + Waiting_Vertices : out LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step) is - Aux_LGV_Id : Library_Graph_Vertex_Id; - - begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - pragma Assert (Needs_Elaboration (G, LGV_Id)); - pragma Assert (Present (Set)); - - if Is_Elaborable_Vertex (G, LGV_Id) then - Add_Vertex - (G => G, - LGV_Id => LGV_Id, - Set => Set, - Msg => Msg, - Step => Step, - Indent => Indent); + pragma Assert (Present (Comp)); - -- Assume that there is no extra vertex that needs to be added + Num_Of_Vertices : constant Natural := + Number_Of_Component_Vertices (G, Comp); - Aux_LGV_Id := No_Library_Graph_Vertex; + Iter : Component_Vertex_Iterator; + Vertex : Library_Graph_Vertex_Id; - -- A spec-body pair where the spec carries pragma Elaborate_Body - -- must be treated as one vertex for elaboration purposes. If one - -- of them is elaborable, then the other is also elaborable. This - -- property is guaranteed by predicate Is_Elaborable_Vertex. + begin + Elaborable_Vertices := LGV_Sets.Create (Num_Of_Vertices); + Waiting_Vertices := LGV_Sets.Create (Num_Of_Vertices); - if Is_Body_Of_Spec_With_Elaborate_Body (G, LGV_Id) then - Aux_LGV_Id := Proper_Spec (G, LGV_Id); - pragma Assert (Present (Aux_LGV_Id)); + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, Vertex); - elsif Is_Spec_With_Elaborate_Body (G, LGV_Id) then - Aux_LGV_Id := Proper_Body (G, LGV_Id); - pragma Assert (Present (Aux_LGV_Id)); - end if; + -- Add the vertex to the proper set depending on whether it can be + -- elaborated. - if Present (Aux_LGV_Id) then - pragma Assert (Needs_Elaboration (G, Aux_LGV_Id)); + if Is_Elaborable_Vertex (G, Vertex) then + Insert_Vertex + (G => G, + Vertex => Vertex, + Set => Elaborable_Vertices, + Msg => "add elaborable component vertex", + Step => Step, + Indent => No_Indentation); - Add_Vertex + else + Insert_Vertex (G => G, - LGV_Id => Aux_LGV_Id, - Set => Set, - Msg => Msg, + Vertex => Vertex, + Set => Waiting_Vertices, + Msg => "add waiting component vertex", Step => Step, - Indent => Indent); + Indent => No_Indentation); end if; - end if; - end Add_Vertex_If_Elaborable; + end loop; + end Create_Component_Vertex_Sets; - ------------------------------- - -- Create_All_Candidates_Set -- - ------------------------------- + ------------------------ + -- Create_Vertex_Sets -- + ------------------------ - function Create_All_Candidates_Set - (G : Library_Graph; - Step : Elaboration_Order_Step) return Membership_Set + procedure Create_Vertex_Sets + (G : Library_Graph; + Elaborable_Vertices : out LGV_Sets.Membership_Set; + Waiting_Vertices : out LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step) is + pragma Assert (Present (G)); + + Num_Of_Vertices : constant Natural := Number_Of_Vertices (G); + Iter : Library_Graphs.All_Vertex_Iterator; - LGV_Id : Library_Graph_Vertex_Id; - Set : Membership_Set; + Vertex : Library_Graph_Vertex_Id; begin - pragma Assert (Present (G)); + Elaborable_Vertices := LGV_Sets.Create (Num_Of_Vertices); + Waiting_Vertices := LGV_Sets.Create (Num_Of_Vertices); - Set := Create (Number_Of_Vertices (G)); Iter := Iterate_All_Vertices (G); while Has_Next (Iter) loop - Next (Iter, LGV_Id); - pragma Assert (Present (LGV_Id)); - - Add_Vertex_If_Elaborable - (G => G, - LGV_Id => LGV_Id, - Set => Set, - Msg => Add_To_All_Candidates_Msg, - Step => Step, - Indent => No_Indentation); - end loop; + Next (Iter, Vertex); - return Set; - end Create_All_Candidates_Set; + -- Add the vertex to the proper set depending on whether it can be + -- elaborated. - ------------------------------------- - -- Create_Component_Candidates_Set -- - ------------------------------------- - - function Create_Component_Candidates_Set - (G : Library_Graph; - Comp : Component_Id; - Step : Elaboration_Order_Step) return Membership_Set - is - Iter : Component_Vertex_Iterator; - LGV_Id : Library_Graph_Vertex_Id; - Set : Membership_Set; - - begin - pragma Assert (Present (G)); - pragma Assert (Present (Comp)); - - Set := Create (Number_Of_Component_Vertices (G, Comp)); - Iter := Iterate_Component_Vertices (G, Comp); - while Has_Next (Iter) loop - Next (Iter, LGV_Id); - pragma Assert (Present (LGV_Id)); + if Is_Elaborable_Vertex (G, Vertex) then + Insert_Vertex + (G => G, + Vertex => Vertex, + Set => Elaborable_Vertices, + Msg => "add elaborable vertex", + Step => Step, + Indent => No_Indentation); - Add_Vertex_If_Elaborable - (G => G, - LGV_Id => LGV_Id, - Set => Set, - Msg => Add_To_Comp_Candidates_Msg, - Step => Step, - Indent => No_Indentation); + else + Insert_Vertex + (G => G, + Vertex => Vertex, + Set => Waiting_Vertices, + Msg => "add waiting vertex", + Step => Step, + Indent => No_Indentation); + end if; end loop; - - return Set; - end Create_Component_Candidates_Set; + end Create_Vertex_Sets; ------------------------- -- Elaborate_Component -- ------------------------- procedure Elaborate_Component - (G : Library_Graph; - Comp : Component_Id; - All_Candidates : Membership_Set; - Remaining_Vertices : in out Natural; - Order : in out Unit_Id_Table; - Step : Elaboration_Order_Step) + (G : Library_Graph; + Comp : Component_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step) is - Candidate : Library_Graph_Vertex_Id; - Comp_Candidates : Membership_Set; + Comp_Elaborable_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Vertex : Library_Graph_Vertex_Id; begin pragma Assert (Present (G)); pragma Assert (Present (Comp)); - pragma Assert (Present (All_Candidates)); + pragma Assert (LGV_Sets.Present (All_Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (All_Waiting_Vertices)); Trace_Component (G => G, @@ -499,35 +508,81 @@ package body Bindo.Elaborators is Msg => "elaborating component", Step => Step); - Comp_Candidates := Create_Component_Candidates_Set (G, Comp, Step); + -- Divide all vertices of the component into an elaborable and + -- waiting vertex set. + + Create_Component_Vertex_Sets + (G => G, + Comp => Comp, + Elaborable_Vertices => Comp_Elaborable_Vertices, + Waiting_Vertices => Comp_Waiting_Vertices, + Step => Step); loop - Candidate := - Find_Best_Candidate + Trace_Vertices + (G => G, + Set => Comp_Elaborable_Vertices, + Set_Msg => "elaborable component vertices", + Vertex_Msg => "elaborable component vertex", + Step => Step, + Indent => Nested_Indentation); + + Trace_Vertices + (G => G, + Set => Comp_Waiting_Vertices, + Set_Msg => "waiting component vertices", + Vertex_Msg => "waiting component vertex", + Step => Step, + Indent => Nested_Indentation); + + Vertex := + Find_Best_Elaborable_Vertex (G => G, - Set => Comp_Candidates, + Set => Comp_Elaborable_Vertices, Step => Step, Indent => Nested_Indentation); - -- Stop the elaboration of the component when there is no suitable - -- candidate. This indicates that either all vertices within the - -- component have been elaborated, or the library graph contains a - -- circularity. + -- The component lacks an elaborable vertex. This indicates that + -- either all vertices of the component have been elaborated or + -- the graph has a circularity. Locate the best weak vertex that + -- was compiled with the dynamic model to elaborate from the set + -- waiting vertices. This action assumes that certain invocations + -- will not take place at elaboration time. An order produced in + -- this fashion may fail an ABE check at run time. + + if not Present (Vertex) then + Vertex := + Find_Best_Weakly_Elaborable_Vertex + (G => G, + Set => Comp_Waiting_Vertices, + Step => Step, + Indent => Nested_Indentation); + end if; + + -- Stop the elaboration when either all vertices of the component + -- have been elaborated, or the graph contains a circularity. - exit when not Present (Candidate); + exit when not Present (Vertex); + + -- Try to elaborate as many vertices within the component as + -- possible. Each successful elaboration signals the appropriate + -- successors and components that they have one less predecessor + -- to wait on. Elaborate_Vertex - (G => G, - LGV_Id => Candidate, - All_Candidates => All_Candidates, - Comp_Candidates => Comp_Candidates, - Remaining_Vertices => Remaining_Vertices, - Order => Order, - Step => Step, - Indent => Nested_Indentation); + (G => G, + Vertex => Vertex, + All_Elaborable_Vertices => All_Elaborable_Vertices, + All_Waiting_Vertices => All_Waiting_Vertices, + Comp_Elaborable_Vertices => Comp_Elaborable_Vertices, + Comp_Waiting_Vertices => Comp_Waiting_Vertices, + Order => Order, + Step => Step, + Indent => Nested_Indentation); end loop; - Destroy (Comp_Candidates); + LGV_Sets.Destroy (Comp_Elaborable_Vertices); + LGV_Sets.Destroy (Comp_Waiting_Vertices); end Elaborate_Component; ----------------------------- @@ -539,77 +594,97 @@ package body Bindo.Elaborators is Order : out Unit_Id_Table; Status : out Elaboration_Order_Status) is - All_Candidates : Membership_Set; - Candidate : Library_Graph_Vertex_Id; - Comp : Component_Id; - Remaining_Vertices : Natural; - Step : Elaboration_Order_Step; + Elaborable_Vertices : LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step; + Vertex : Library_Graph_Vertex_Id; + Waiting_Vertices : LGV_Sets.Membership_Set; begin pragma Assert (Present (G)); Step := Initial_Step; - All_Candidates := Create_All_Candidates_Set (G, Step); - Remaining_Vertices := Number_Of_Vertices (G); + -- Divide all vertices of the library graph into an elaborable and + -- waiting vertex set. + + Create_Vertex_Sets + (G => G, + Elaborable_Vertices => Elaborable_Vertices, + Waiting_Vertices => Waiting_Vertices, + Step => Step); loop Step := Step + 1; - Trace_Candidate_Vertices - (G => G, - Set => All_Candidates, - Step => Step); - - Trace_Unelaborated_Vertices - (G => G, - Count => Remaining_Vertices, - Step => Step); - - Candidate := - Find_Best_Candidate + Trace_Vertices + (G => G, + Set => Elaborable_Vertices, + Set_Msg => "elaborable vertices", + Vertex_Msg => "elaborable vertex", + Step => Step, + Indent => No_Indentation); + + Trace_Vertices + (G => G, + Set => Waiting_Vertices, + Set_Msg => "waiting vertices", + Vertex_Msg => "waiting vertex", + Step => Step, + Indent => No_Indentation); + + Vertex := + Find_Best_Elaborable_Vertex (G => G, - Set => All_Candidates, + Set => Elaborable_Vertices, Step => Step, Indent => No_Indentation); - -- Stop the elaboration when there is no suitable candidate. This - -- indicates that either all units were elaborated or the library - -- graph contains a circularity. + -- The graph lacks an elaborable vertex. This indicates that + -- either all vertices have been elaborated or the graph has a + -- circularity. Find the best weak vertex that was compiled with + -- the dynamic model to elaborate from set of waiting vertices. + -- This action assumes that certain invocations will not take + -- place at elaboration time. An order produced in this fashion + -- may fail an ABE check at run time. + + if not Present (Vertex) then + Vertex := + Find_Best_Weakly_Elaborable_Vertex + (G => G, + Set => Waiting_Vertices, + Step => Step, + Indent => No_Indentation); + end if; - exit when not Present (Candidate); + -- Stop the elaboration when either all vertices of the graph have + -- been elaborated, or the graph contains a circularity. - -- Elaborate the component of the candidate vertex by trying to - -- elaborate as many vertices within the component as possible. - -- Each successful elaboration signals the appropriate successors - -- and their components that they have one less predecessor to - -- wait on. This may add new candidates to set All_Candidates. + exit when not Present (Vertex); - Comp := Component (G, Candidate); - pragma Assert (Present (Comp)); + -- Elaborate the component of the vertex by trying to elaborate as + -- many vertices within the component as possible. Each successful + -- elaboration signals the appropriate successors and components + -- that they have one less predecessor to wait on. Elaborate_Component - (G => G, - Comp => Comp, - All_Candidates => All_Candidates, - Remaining_Vertices => Remaining_Vertices, - Order => Order, - Step => Step); + (G => G, + Comp => Component (G, Vertex), + All_Elaborable_Vertices => Elaborable_Vertices, + All_Waiting_Vertices => Waiting_Vertices, + Order => Order, + Step => Step); end loop; - Destroy (All_Candidates); - - -- The library graph contains an Elaborate_All circularity when - -- at least one edge subject to the related pragma appears in a - -- component. + -- The graph contains an Elaborate_All circularity when at least one + -- edge subject to the related pragma appears in a component. if Has_Elaborate_All_Cycle (G) then Status := Order_Has_Elaborate_All_Circularity; - -- The library contains a circularity when at least one vertex failed + -- The graph contains a circularity when at least one vertex failed -- to elaborate. - elsif Remaining_Vertices /= 0 then + elsif LGV_Sets.Size (Waiting_Vertices) /= 0 then Status := Order_Has_Circularity; -- Otherwise the elaboration order is satisfactory @@ -617,6 +692,9 @@ package body Bindo.Elaborators is else Status := Order_OK; end if; + + LGV_Sets.Destroy (Elaborable_Vertices); + LGV_Sets.Destroy (Waiting_Vertices); end Elaborate_Library_Graph; --------------------- @@ -627,11 +705,14 @@ package body Bindo.Elaborators is (Order : out Unit_Id_Table; Main_Lib_File : File_Name_Type) is - Main_Lib_Unit : constant Unit_Id := - Corresponding_Unit (Unit_Name_Type (Main_Lib_File)); + pragma Unreferenced (Main_Lib_File); + + Inv_Graph : Invocation_Graph; + Lib_Graph : Library_Graph; + Status : Elaboration_Order_Status; begin - pragma Assert (Present (Main_Lib_Unit)); + Start_Phase (Unit_Elaboration); -- Initialize all unit-related data structures and gather all units -- that need elaboration. @@ -639,71 +720,14 @@ package body Bindo.Elaborators is Initialize_Units; Collect_Elaborable_Units; - Write_ALI_Tables; - - -- Choose the proper elaboration strategy based on whether the main - -- library unit was compiled with dynamic elaboration checks. - - if Is_Dynamically_Elaborated (Main_Lib_Unit) then - Elaborate_Units_Dynamic (Order); - else - Elaborate_Units_Static (Order); - end if; - - Validate_Elaboration_Order (Order); - Write_Elaboration_Order (Order); - - -- Enumerate the sources referenced in the closure of the order - - Write_Unit_Closure (Order); - - -- Destroy all unit-delated data structures - - Finalize_Units; - - exception - when others => - Finalize_Units; - raise; - end Elaborate_Units; - - ---------------------------- - -- Elaborate_Units_Common -- - ---------------------------- - - procedure Elaborate_Units_Common - (Use_Inv_Graph : Boolean; - Inv_Graph : out Invocation_Graph; - Lib_Graph : out Library_Graph; - Order : out Unit_Id_Table; - Status : out Elaboration_Order_Status) - is - begin - -- Create, validate, and output the library graph that captures the - -- dependencies between library items. + -- Create the library graph that captures the dependencies between + -- library items. Lib_Graph := Build_Library_Graph; - Validate_Library_Graph (Lib_Graph); - Write_Library_Graph (Lib_Graph); - - -- Create, validate, output, and use the invocation graph that - -- represents the flow of execusion only when requested by the - -- caller. - if Use_Inv_Graph then - Inv_Graph := Build_Invocation_Graph (Lib_Graph); - Validate_Invocation_Graph (Inv_Graph); - Write_Invocation_Graph (Inv_Graph); + -- Create the invocation graph that represents the flow of execution - -- Otherwise the invocation graph is not used. Create a dummy graph - -- as this allows for a uniform behavior on the caller side. - - else - Inv_Graph := - Invocation_Graphs.Create - (Initial_Vertices => 1, - Initial_Edges => 1); - end if; + Inv_Graph := Build_Invocation_Graph (Lib_Graph); -- Traverse the invocation graph starting from elaboration code in -- order to discover transitions of the execution flow from a unit @@ -711,398 +735,604 @@ package body Bindo.Elaborators is Augment_Library_Graph (Inv_Graph, Lib_Graph); - -- Create and output the component graph by collapsing all library - -- items into library units and traversing the library graph. - - Find_Components (Lib_Graph); - Write_Library_Graph (Lib_Graph); - - -- Traverse the library graph to determine the elaboration order of - -- units. + -- Create the component graph by collapsing all library items into + -- library units and traversing the library graph. - Elaborate_Library_Graph - (G => Lib_Graph, - Order => Order, - Status => Status); - end Elaborate_Units_Common; + Find_Components (Lib_Graph); - ----------------------------- - -- Elaborate_Units_Dynamic -- - ----------------------------- + -- Output the contents of the ALI tables and both graphs to standard + -- output now that they have been fully decorated. - procedure Elaborate_Units_Dynamic (Order : out Unit_Id_Table) is - Dyn_Inv_Graph : Invocation_Graph; - Dyn_Lib_Graph : Library_Graph; - Dyn_Order : Unit_Id_Table; - Mix_Inv_Graph : Invocation_Graph; - Mix_Lib_Graph : Library_Graph; - Mix_Order : Unit_Id_Table; - Status : Elaboration_Order_Status; + Write_ALI_Tables; + Write_Invocation_Graph (Inv_Graph); + Write_Library_Graph (Lib_Graph); - begin - -- Attempt to elaborate the units in the library graph by mixing in - -- the information from the invocation graph. This assumes that all - -- invocations will take place at elaboration time. + -- Traverse the library graph to determine the elaboration order of + -- units. - Elaborate_Units_Common - (Use_Inv_Graph => True, - Inv_Graph => Mix_Inv_Graph, - Lib_Graph => Mix_Lib_Graph, - Order => Mix_Order, - Status => Status); + Elaborate_Library_Graph (Lib_Graph, Order, Status); -- The elaboration order is satisfactory if Status = Order_OK then - Order := Mix_Order; + Validate_Elaboration_Order (Order); - -- The library graph contains an Elaborate_All circularity. There is - -- no point in re-elaborating the units without the information from - -- the invocation graph because the circularity will persist. + -- Set attribute Elab_Position of table ALI.Units for all units in + -- the elaboration order. - elsif Status = Order_Has_Elaborate_All_Circularity then - Error_Msg ("elaboration circularity detected"); + Set_Unit_Elaboration_Positions (Order); - -- Report error here + -- Output the dependencies among units when switch -e (output + -- complete list of elaboration order dependencies) is active. - -- Otherwise the library graph contains a circularity, or the extra - -- information provided by the invocation graph caused a circularity. - -- Re-elaborate the units without using the invocation graph. This - -- assumes that all invocations will not take place at elaboration - -- time. - - else - pragma Assert (Status = Order_Has_Circularity); + Write_Dependencies (Lib_Graph); - Elaborate_Units_Common - (Use_Inv_Graph => False, - Inv_Graph => Dyn_Inv_Graph, - Lib_Graph => Dyn_Lib_Graph, - Order => Dyn_Order, - Status => Status); + -- Output the elaboration order when switch -l (output chosen + -- elaboration order) is in effect. - -- The elaboration order is satisfactory. The elaboration of the - -- program may still fail at runtime with an ABE. + Write_Elaboration_Order (Order); - if Status = Order_OK then - Order := Dyn_Order; + -- Output the sources referenced in the closure of the order when + -- switch -R (list sources referenced in closure) is in effect. - -- Otherwise the library graph contains a circularity without the - -- extra information provided by the invocation graph. Diagnose - -- the circularity. + Write_Unit_Closure (Order); - else - Error_Msg ("elaboration circularity detected"); - - -- Report error here - end if; + -- Otherwise the library graph contains at least one circularity - Destroy (Dyn_Inv_Graph); - Destroy (Dyn_Lib_Graph); - end if; - - Destroy (Mix_Inv_Graph); - Destroy (Mix_Lib_Graph); - - -- Halt the bind as there is no satisfactory elaboration order - - if Status /= Order_OK then - raise Unrecoverable_Error; - end if; - end Elaborate_Units_Dynamic; - - ---------------------------- - -- Elaborate_Units_Static -- - ---------------------------- - - procedure Elaborate_Units_Static (Order : out Unit_Id_Table) is - Inv_Graph : Invocation_Graph; - Lib_Graph : Library_Graph; - Status : Elaboration_Order_Status; - - begin - -- Attempt to elaborate the units in the library graph by mixing in - -- the information from the invocation graph. This assumes that all - -- invocations will take place at elaboration time. - - Elaborate_Units_Common - (Use_Inv_Graph => True, - Inv_Graph => Inv_Graph, - Lib_Graph => Lib_Graph, - Order => Order, - Status => Status); - - -- The augmented library graph contains a circularity - - if Status /= Order_OK then - Error_Msg ("elaboration circularity detected"); - - -- Report error here + else + Diagnose_Circularities (Inv_Graph, Lib_Graph); end if; Destroy (Inv_Graph); Destroy (Lib_Graph); - -- Halt the bind as there is no satisfactory elaboration order + -- Destroy all unit-related data structures + + Finalize_Units; + End_Phase (Unit_Elaboration); + + -- Halt the bind when there is no satisfactory elaboration order if Status /= Order_OK then raise Unrecoverable_Error; end if; - end Elaborate_Units_Static; + end Elaborate_Units; ---------------------- -- Elaborate_Vertex -- ---------------------- procedure Elaborate_Vertex - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - All_Candidates : Membership_Set; - Comp_Candidates : Membership_Set; - Remaining_Vertices : in out Natural; - Order : in out Unit_Id_Table; - Step : Elaboration_Order_Step; - Indent : Indentation_Level) + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Elaborable_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Order : in out Unit_Id_Table; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) is - Body_LGV_Id : Library_Graph_Vertex_Id; - U_Id : Unit_Id; - begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - pragma Assert (Needs_Elaboration (G, LGV_Id)); - pragma Assert (Present (All_Candidates)); - pragma Assert (Present (Comp_Candidates)); + pragma Assert (Present (Vertex)); + pragma Assert (Needs_Elaboration (G, Vertex)); + pragma Assert (LGV_Sets.Present (All_Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (All_Waiting_Vertices)); + pragma Assert (LGV_Sets.Present (Comp_Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (Comp_Waiting_Vertices)); Trace_Vertex (G => G, - LGV_Id => LGV_Id, + Vertex => Vertex, Msg => "elaborating vertex", Step => Step, Indent => Indent); - -- Remove the vertex from both candidate sets. This is needed when + -- Remove the vertex from both elaborable sets. This is needed when -- the vertex is both an overall best candidate among all vertices, - -- and the best candidate within the component. There is no need to - -- check that the vertex is present in either set because the set - -- implementation handles this case. + -- and the best candidate within the component. - Delete (All_Candidates, LGV_Id); - Delete (Comp_Candidates, LGV_Id); + LGV_Sets.Delete (All_Elaborable_Vertices, Vertex); + LGV_Sets.Delete (Comp_Elaborable_Vertices, Vertex); + + -- Remove the vertex from both waiting sets. This is needed when a + -- weakly elaborable vertex is both an overall best candidate among + -- all waiting vertices and the best waiting candidate within the + -- component. + + LGV_Sets.Delete (All_Waiting_Vertices, Vertex); + LGV_Sets.Delete (Comp_Waiting_Vertices, Vertex); -- Mark the vertex as elaborated in order to prevent further attempts -- to re-elaborate it. - Set_In_Elaboration_Order (G, LGV_Id); + Set_In_Elaboration_Order (G, Vertex); -- Add the unit represented by the vertex to the elaboration order - U_Id := Unit (G, LGV_Id); - pragma Assert (Present (U_Id)); - - Unit_Id_Tables.Append (Order, U_Id); - - -- There is now one fewer vertex to elaborate - - Remaining_Vertices := Remaining_Vertices - 1; + Unit_Id_Tables.Append (Order, Unit (G, Vertex)); -- Notify all successors and their components that they have one -- fewer predecessor to wait on. This may cause some successors to -- be included in one of the sets. Update_Successors - (G => G, - Pred => LGV_Id, - All_Candidates => All_Candidates, - Comp_Candidates => Comp_Candidates, - Step => Step, - Indent => Indent + Nested_Indentation); - - -- The vertex denotes a spec with a completing body, and is subject - -- to pragma Elaborate_Body. Elaborate the body in order to satisfy - -- the semantics of the pragma. - - if Is_Spec_With_Elaborate_Body (G, LGV_Id) then - Body_LGV_Id := Proper_Body (G, LGV_Id); - pragma Assert (Present (Body_LGV_Id)); - + (G => G, + Vertex => Vertex, + All_Elaborable_Vertices => All_Elaborable_Vertices, + All_Waiting_Vertices => All_Waiting_Vertices, + Comp_Elaborable_Vertices => Comp_Elaborable_Vertices, + Comp_Waiting_Vertices => Comp_Waiting_Vertices, + Step => Step, + Indent => Indent + Nested_Indentation); + + -- Elaborate an eligible completing body immediately after its spec. + -- This action satisfies the semantics of pragma Elaborate_Body. In + -- addition, it ensures that a body will not "drift" too far from its + -- spec in case invocation edges are removed from the library graph. + + if Has_Elaborable_Body (G, Vertex) then Elaborate_Vertex - (G => G, - LGV_Id => Body_LGV_Id, - All_Candidates => All_Candidates, - Comp_Candidates => Comp_Candidates, - Remaining_Vertices => Remaining_Vertices, - Order => Order, - Step => Step, - Indent => Indent); + (G => G, + Vertex => Proper_Body (G, Vertex), + All_Elaborable_Vertices => All_Elaborable_Vertices, + All_Waiting_Vertices => All_Waiting_Vertices, + Comp_Elaborable_Vertices => Comp_Elaborable_Vertices, + Comp_Waiting_Vertices => Comp_Waiting_Vertices, + Order => Order, + Step => Step, + Indent => Indent); end if; end Elaborate_Vertex; - ------------------------- - -- Find_Best_Candidate -- - ------------------------- + --------------------------------- + -- Find_Best_Elaborable_Vertex -- + --------------------------------- - function Find_Best_Candidate + function Find_Best_Elaborable_Vertex (G : Library_Graph; - Set : Membership_Set; + Set : LGV_Sets.Membership_Set; Step : Elaboration_Order_Step; Indent : Indentation_Level) return Library_Graph_Vertex_Id is - Best : Library_Graph_Vertex_Id; - Curr : Library_Graph_Vertex_Id; - Iter : Iterator; + begin + pragma Assert (Present (G)); + pragma Assert (LGV_Sets.Present (Set)); + + return + Find_Best_Vertex + (G => G, + Set => Set, + Is_Suitable_Vertex => + Is_Suitable_Elaborable_Vertex'Access, + Compare_Vertices => + Is_Better_Elaborable_Vertex'Access, + Initial_Best_Msg => "initial best elaborable vertex", + Subsequent_Best_Msg => "better elaborable vertex", + Step => Step, + Indent => Indent); + end Find_Best_Elaborable_Vertex; + + ---------------------- + -- Find_Best_Vertex -- + ---------------------- + + function Find_Best_Vertex + (G : Library_Graph; + Set : LGV_Sets.Membership_Set; + Is_Suitable_Vertex : LGV_Predicate_Ptr; + Compare_Vertices : LGV_Comparator_Ptr; + Initial_Best_Msg : String; + Subsequent_Best_Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + return Library_Graph_Vertex_Id + is + Best_Vertex : Library_Graph_Vertex_Id; + Current_Vertex : Library_Graph_Vertex_Id; + Iter : LGV_Sets.Iterator; begin pragma Assert (Present (G)); - pragma Assert (Present (Set)); + pragma Assert (LGV_Sets.Present (Set)); + pragma Assert (Is_Suitable_Vertex /= null); + pragma Assert (Compare_Vertices /= null); -- Assume that there is no candidate - Best := No_Library_Graph_Vertex; + Best_Vertex := No_Library_Graph_Vertex; + + -- Inspect all vertices in the set, looking for the best candidate + -- according to the comparator. + + Iter := LGV_Sets.Iterate (Set); + while LGV_Sets.Has_Next (Iter) loop + LGV_Sets.Next (Iter, Current_Vertex); + pragma Assert (Needs_Elaboration (G, Current_Vertex)); + + if Is_Suitable_Vertex.all (G, Current_Vertex) then + + -- A previous iteration already picked the best candidate. + -- Update the best candidate when the current vertex is a + -- better choice. + + if Present (Best_Vertex) then + if Compare_Vertices.all + (G => G, + Vertex => Current_Vertex, + Compared_To => Best_Vertex) = Higher_Precedence + then + Best_Vertex := Current_Vertex; + + Trace_Vertex + (G => G, + Vertex => Best_Vertex, + Msg => Subsequent_Best_Msg, + Step => Step, + Indent => Indent); + end if; + + -- Otherwise this is the first candidate + + else + Best_Vertex := Current_Vertex; + + Trace_Vertex + (G => G, + Vertex => Best_Vertex, + Msg => Initial_Best_Msg, + Step => Step, + Indent => Indent); + end if; + end if; + end loop; - -- Inspect all vertices in the set, looking for the best candidate to - -- elaborate. + return Best_Vertex; + end Find_Best_Vertex; - Iter := Iterate (Set); - while Has_Next (Iter) loop - Next (Iter, Curr); + ---------------------------------------- + -- Find_Best_Weakly_Elaborable_Vertex -- + ---------------------------------------- + + function Find_Best_Weakly_Elaborable_Vertex + (G : Library_Graph; + Set : LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (LGV_Sets.Present (Set)); + + return + Find_Best_Vertex + (G => G, + Set => Set, + Is_Suitable_Vertex => + Is_Suitable_Weakly_Elaborable_Vertex'Access, + Compare_Vertices => + Is_Better_Weakly_Elaborable_Vertex'Access, + Initial_Best_Msg => "initial best weakly elaborable vertex", + Subsequent_Best_Msg => "better weakly elaborable vertex", + Step => Step, + Indent => Indent); + end Find_Best_Weakly_Elaborable_Vertex; + + ------------------------- + -- Has_Elaborable_Body -- + ------------------------- + + function Has_Elaborable_Body + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); - pragma Assert (Present (Curr)); - pragma Assert (Needs_Elaboration (G, Curr)); + -- The body of an already-elaborated spec subject to Elaborate_Body + -- is always elaborable. - -- Update the best candidate when there is no such candidate + if Is_Spec_With_Elaborate_Body (G, Vertex) then + return True; - if not Present (Best) then - Best := Curr; + elsif Is_Spec_With_Body (G, Vertex) then + return Is_Elaborable_Vertex (G, Proper_Body (G, Vertex)); + end if; - Trace_Vertex - (G => G, - LGV_Id => Best, - Msg => "initial best candidate vertex", - Step => Step, - Indent => Indent); + return False; + end Has_Elaborable_Body; - -- Update the best candidate when the current vertex is a better - -- choice. + --------------------------------- + -- Insert_Elaborable_Successor -- + --------------------------------- - elsif Is_Better_Candidate - (G => G, - Best_Candid => Best, - New_Candid => Curr) - then - Best := Curr; + procedure Insert_Elaborable_Successor + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + pragma Assert (LGV_Sets.Present (Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (All_Waiting_Vertices)); + pragma Assert (LGV_Sets.Present (Comp_Waiting_Vertices)); - Trace_Vertex - (G => G, - LGV_Id => Best, - Msg => "best candidate vertex", - Step => Step, - Indent => Indent); - end if; - end loop; + Complement : constant Library_Graph_Vertex_Id := + Complementary_Vertex + (G => G, + Vertex => Vertex, + Force_Complement => False); - return Best; - end Find_Best_Candidate; + begin + -- Remove the successor from both waiting vertex sets because it may + -- be the best vertex to elaborate across the whole graph and within + -- its component. - ------------------------- - -- Is_Better_Candidate -- - ------------------------- + LGV_Sets.Delete (All_Waiting_Vertices, Vertex); + LGV_Sets.Delete (Comp_Waiting_Vertices, Vertex); + + Insert_Vertex + (G => G, + Vertex => Vertex, + Set => Elaborable_Vertices, + Msg => Msg, + Step => Step, + Indent => Indent); + + if Present (Complement) then + + -- Remove the complement of the successor from both waiting vertex + -- sets because it may be the best vertex to elaborate across the + -- whole graph and within its component. + + LGV_Sets.Delete (All_Waiting_Vertices, Complement); + LGV_Sets.Delete (Comp_Waiting_Vertices, Complement); + + Insert_Vertex + (G => G, + Vertex => Complement, + Set => Elaborable_Vertices, + Msg => Msg, + Step => Step, + Indent => Indent); + end if; + end Insert_Elaborable_Successor; + + ------------------- + -- Insert_Vertex -- + ------------------- + + procedure Insert_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Set : LGV_Sets.Membership_Set; + Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + pragma Assert (Needs_Elaboration (G, Vertex)); + pragma Assert (LGV_Sets.Present (Set)); + + -- Nothing to do when the vertex is already present in the set + + if LGV_Sets.Contains (Set, Vertex) then + return; + end if; + + Trace_Vertex + (G => G, + Vertex => Vertex, + Msg => Msg, + Step => Step, + Indent => Indent); + + -- Add the vertex to the set + + LGV_Sets.Insert (Set, Vertex); + end Insert_Vertex; + + --------------------------------- + -- Is_Better_Elaborable_Vertex -- + --------------------------------- - function Is_Better_Candidate + function Is_Better_Elaborable_Vertex (G : Library_Graph; - Best_Candid : Library_Graph_Vertex_Id; - New_Candid : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id; + Compared_To : Library_Graph_Vertex_Id) return Precedence_Kind is begin pragma Assert (Present (G)); - pragma Assert (Present (Best_Candid)); - pragma Assert (Present (New_Candid)); + pragma Assert (Present (Vertex)); + pragma Assert (Present (Compared_To)); + + -- Prefer a spec with Elaborate_Body over its corresponding body + + if Is_Elaborate_Body_Pair + (G => G, + Spec_Vertex => Vertex, + Body_Vertex => Compared_To) + then + return Higher_Precedence; + + elsif Is_Elaborate_Body_Pair + (G => G, + Spec_Vertex => Compared_To, + Body_Vertex => Vertex) + then + return Lower_Precedence; -- Prefer a predefined unit over a non-predefined unit - if Is_Predefined_Unit (G, Best_Candid) - and then not Is_Predefined_Unit (G, New_Candid) + elsif Is_Predefined_Unit (G, Vertex) + and then not Is_Predefined_Unit (G, Compared_To) then - return False; + return Higher_Precedence; - elsif not Is_Predefined_Unit (G, Best_Candid) - and then Is_Predefined_Unit (G, New_Candid) + elsif not Is_Predefined_Unit (G, Vertex) + and then Is_Predefined_Unit (G, Compared_To) then - return True; + return Lower_Precedence; - -- Prefer an internal unit over a non-iternal unit + -- Prefer an internal unit over a non-internal unit - elsif Is_Internal_Unit (G, Best_Candid) - and then not Is_Internal_Unit (G, New_Candid) + elsif Is_Internal_Unit (G, Vertex) + and then not Is_Internal_Unit (G, Compared_To) then - return False; + return Higher_Precedence; - elsif not Is_Internal_Unit (G, Best_Candid) - and then Is_Internal_Unit (G, New_Candid) + elsif not Is_Internal_Unit (G, Vertex) + and then Is_Internal_Unit (G, Compared_To) then - return True; + return Lower_Precedence; -- Prefer a preelaborated unit over a non-preelaborated unit - elsif Is_Preelaborated_Unit (G, Best_Candid) - and then not Is_Preelaborated_Unit (G, New_Candid) + elsif Is_Preelaborated_Unit (G, Vertex) + and then not Is_Preelaborated_Unit (G, Compared_To) then - return False; + return Higher_Precedence; - elsif not Is_Preelaborated_Unit (G, Best_Candid) - and then Is_Preelaborated_Unit (G, New_Candid) + elsif not Is_Preelaborated_Unit (G, Vertex) + and then Is_Preelaborated_Unit (G, Compared_To) then - return True; + return Lower_Precedence; -- Otherwise default to lexicographical order to ensure deterministic -- behavior. + elsif Uname_Less (Name (G, Vertex), Name (G, Compared_To)) then + return Higher_Precedence; + else - return Uname_Less (Name (G, Best_Candid), Name (G, New_Candid)); + return Lower_Precedence; end if; - end Is_Better_Candidate; + end Is_Better_Elaborable_Vertex; - ------------------------------ - -- Trace_Candidate_Vertices -- - ------------------------------ + ---------------------------------------- + -- Is_Better_Weakly_Elaborable_Vertex -- + ---------------------------------------- - procedure Trace_Candidate_Vertices - (G : Library_Graph; - Set : Membership_Set; - Step : Elaboration_Order_Step) + function Is_Better_Weakly_Elaborable_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Compared_To : Library_Graph_Vertex_Id) return Precedence_Kind is - Iter : Iterator; - LGV_Id : Library_Graph_Vertex_Id; + Comp_Strong_Preds : Natural; + Comp_Weak_Preds : Natural; + Vertex_Strong_Preds : Natural; + Vertex_Weak_Preds : Natural; begin pragma Assert (Present (G)); - pragma Assert (Present (Set)); + pragma Assert (Present (Vertex)); + pragma Assert (Present (Compared_To)); - -- Nothing to do when switch -d_T (output elaboration order trace - -- information) is not in effect. + -- Obtain the number of pending predecessors for both candidates, + -- taking into account Elaborate_Body pairs. - if not Debug_Flag_Underscore_TT then - return; + Pending_Predecessors_For_Elaboration + (G => G, + Vertex => Vertex, + Strong_Preds => Vertex_Strong_Preds, + Weak_Preds => Vertex_Weak_Preds); + + Pending_Predecessors_For_Elaboration + (G => G, + Vertex => Compared_To, + Strong_Preds => Comp_Strong_Preds, + Weak_Preds => Comp_Weak_Preds); + + -- Neither candidate should be waiting on strong predecessors, + -- otherwise the candidate cannot be weakly elaborated. + + pragma Assert (Vertex_Strong_Preds = 0); + pragma Assert (Comp_Strong_Preds = 0); + + -- Prefer a unit with fewer weak predecessors over a unit with more + -- weak predecessors. + + if Vertex_Weak_Preds < Comp_Weak_Preds then + return Higher_Precedence; + + elsif Vertex_Weak_Preds > Comp_Weak_Preds then + return Lower_Precedence; + + -- Otherwise default to lexicographical order to ensure deterministic + -- behavior. + + elsif Uname_Less (Name (G, Vertex), Name (G, Compared_To)) then + return Higher_Precedence; + + else + return Lower_Precedence; end if; + end Is_Better_Weakly_Elaborable_Vertex; - Trace_Step (Step); - Write_Str ("candidate vertices: "); - Write_Int (Int (Size (Set))); - Write_Eol; + ----------------------------------- + -- Is_Suitable_Elaborable_Vertex -- + ----------------------------------- - Iter := Iterate (Set); - while Has_Next (Iter) loop - Next (Iter, LGV_Id); - pragma Assert (Present (LGV_Id)); + function Is_Suitable_Elaborable_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); - Trace_Vertex - (G => G, - LGV_Id => LGV_Id, - Msg => "candidate vertex", - Step => Step, - Indent => Nested_Indentation); + -- A vertex is suitable for elaboration as long it is not waiting on + -- any predecessors, ignoring the static or dynamic model. + + return Is_Elaborable_Vertex (G, Vertex); + end Is_Suitable_Elaborable_Vertex; + + ------------------------------------------ + -- Is_Suitable_Weakly_Elaborable_Vertex -- + ------------------------------------------ + + function Is_Suitable_Weakly_Elaborable_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + -- A vertex is suitable for weak elaboration when it is waiting on + -- weak predecessors only, and the unit it represents was compiled + -- using the dynamic model. + + return + Is_Dynamically_Elaborated (G, Vertex) + and then Is_Weakly_Elaborable_Vertex (G, Vertex); + end Is_Suitable_Weakly_Elaborable_Vertex; + + ------------------------------------ + -- Set_Unit_Elaboration_Positions -- + ------------------------------------ + + procedure Set_Unit_Elaboration_Positions (Order : Unit_Id_Table) is + U_Id : Unit_Id; + + begin + for Position in Unit_Id_Tables.First .. + Unit_Id_Tables.Last (Order) + loop + U_Id := Order.Table (Position); + + ALI.Units.Table (U_Id).Elab_Position := Position; end loop; - end Trace_Candidate_Vertices; + end Set_Unit_Elaboration_Positions; --------------------- -- Trace_Component -- @@ -1118,8 +1348,8 @@ package body Bindo.Elaborators is pragma Assert (Present (G)); pragma Assert (Present (Comp)); - -- Nothing to do when switch -d_T (output elaboration order trace - -- information) is not in effect. + -- Nothing to do when switch -d_T (output elaboration order and cycle + -- detection trace information) is not in effect. if not Debug_Flag_Underscore_TT then return; @@ -1134,8 +1364,14 @@ package body Bindo.Elaborators is Trace_Step (Step); Indent_By (Nested_Indentation); - Write_Str ("pending predecessors: "); - Write_Num (Int (Pending_Predecessors (G, Comp))); + Write_Str ("pending strong predecessors: "); + Write_Num (Int (Pending_Strong_Predecessors (G, Comp))); + Write_Eol; + + Trace_Step (Step); + Indent_By (Nested_Indentation); + Write_Str ("pending weak predecessors : "); + Write_Num (Int (Pending_Weak_Predecessors (G, Comp))); Write_Eol; end Trace_Component; @@ -1145,8 +1381,8 @@ package body Bindo.Elaborators is procedure Trace_Step (Step : Elaboration_Order_Step) is begin - -- Nothing to do when switch -d_T (output elaboration order trace - -- information) is not in effect. + -- Nothing to do when switch -d_T (output elaboration order and cycle + -- detection trace information) is not in effect. if not Debug_Flag_Underscore_TT then return; @@ -1158,72 +1394,27 @@ package body Bindo.Elaborators is Write_Str (": "); end Trace_Step; - --------------------------------- - -- Trace_Unelaborated_Vertices -- - --------------------------------- - - procedure Trace_Unelaborated_Vertices - (G : Library_Graph; - Count : Natural; - Step : Elaboration_Order_Step) - is - Iter : Library_Graphs.All_Vertex_Iterator; - LGV_Id : Library_Graph_Vertex_Id; - - begin - pragma Assert (Present (G)); - - -- Nothing to do when switch -d_T (output elaboration order trace - -- information) is not in effect. - - if not Debug_Flag_Underscore_TT then - return; - end if; - - Trace_Step (Step); - Write_Str ("remaining unelaborated vertices: "); - Write_Int (Int (Count)); - Write_Eol; - - Iter := Iterate_All_Vertices (G); - while Has_Next (Iter) loop - Next (Iter, LGV_Id); - pragma Assert (Present (LGV_Id)); - - if Needs_Elaboration (G, LGV_Id) - and then not In_Elaboration_Order (G, LGV_Id) - then - Trace_Vertex - (G => G, - LGV_Id => LGV_Id, - Msg => "remaining vertex", - Step => Step, - Indent => Nested_Indentation); - end if; - end loop; - end Trace_Unelaborated_Vertices; - ------------------ -- Trace_Vertex -- ------------------ procedure Trace_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Msg : String; Step : Elaboration_Order_Step; Indent : Indentation_Level) is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - Comp : constant Component_Id := Component (G, LGV_Id); - - pragma Assert (Present (Comp)); + Attr_Indent : constant Indentation_Level := + Indent + Nested_Indentation; + Comp : constant Component_Id := Component (G, Vertex); begin - -- Nothing to do when switch -d_T (output elaboration order trace - -- information) is not in effect. + -- Nothing to do when switch -d_T (output elaboration order and cycle + -- detection trace information) is not in effect. if not Debug_Flag_Underscore_TT then return; @@ -1233,74 +1424,141 @@ package body Bindo.Elaborators is Indent_By (Indent); Write_Str (Msg); Write_Str (" (LGV_Id_"); - Write_Int (Int (LGV_Id)); + Write_Int (Int (Vertex)); Write_Str (")"); Write_Eol; Trace_Step (Step); - Indent_By (Indent + Nested_Indentation); + Indent_By (Attr_Indent); Write_Str ("name = "); - Write_Name (Name (G, LGV_Id)); + Write_Name (Name (G, Vertex)); Write_Eol; Trace_Step (Step); - Indent_By (Indent + Nested_Indentation); + Indent_By (Attr_Indent); Write_Str ("Component (Comp_Id_"); Write_Int (Int (Comp)); Write_Str (")"); Write_Eol; Trace_Step (Step); - Indent_By (Indent + Nested_Indentation); - Write_Str ("pending predecessors: "); - Write_Num (Int (Pending_Predecessors (G, LGV_Id))); + Indent_By (Attr_Indent); + Write_Str ("pending strong predecessors: "); + Write_Num (Int (Pending_Strong_Predecessors (G, Vertex))); + Write_Eol; + + Trace_Step (Step); + Indent_By (Attr_Indent); + Write_Str ("pending weak predecessors : "); + Write_Num (Int (Pending_Weak_Predecessors (G, Vertex))); + Write_Eol; + + Trace_Step (Step); + Indent_By (Attr_Indent); + Write_Str ("pending strong components : "); + Write_Num (Int (Pending_Strong_Predecessors (G, Comp))); Write_Eol; Trace_Step (Step); - Indent_By (Indent + Nested_Indentation); - Write_Str ("pending components : "); - Write_Num (Int (Pending_Predecessors (G, Comp))); + Indent_By (Attr_Indent); + Write_Str ("pending weak components : "); + Write_Num (Int (Pending_Weak_Predecessors (G, Comp))); Write_Eol; end Trace_Vertex; + -------------------- + -- Trace_Vertices -- + -------------------- + + procedure Trace_Vertices + (G : Library_Graph; + Set : LGV_Sets.Membership_Set; + Set_Msg : String; + Vertex_Msg : String; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) + is + Vertex_Indent : constant Indentation_Level := + Indent + Nested_Indentation; + + Iter : LGV_Sets.Iterator; + Vertex : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (LGV_Sets.Present (Set)); + + -- Nothing to do when switch -d_T (output elaboration order and cycle + -- detection trace information) is not in effect. + + if not Debug_Flag_Underscore_TT then + return; + end if; + + Trace_Step (Step); + Indent_By (Indent); + Write_Str (Set_Msg); + Write_Str (": "); + Write_Int (Int (LGV_Sets.Size (Set))); + Write_Eol; + + Iter := LGV_Sets.Iterate (Set); + while LGV_Sets.Has_Next (Iter) loop + LGV_Sets.Next (Iter, Vertex); + + Trace_Vertex + (G => G, + Vertex => Vertex, + Msg => Vertex_Msg, + Step => Step, + Indent => Vertex_Indent); + end loop; + end Trace_Vertices; + ---------------------- -- Update_Successor -- ---------------------- procedure Update_Successor - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - Succ : Library_Graph_Vertex_Id; - All_Candidates : Membership_Set; - Comp_Candidates : Membership_Set; - Step : Elaboration_Order_Step; - Indent : Indentation_Level) + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Elaborable_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) is pragma Assert (Present (G)); - pragma Assert (Present (Pred)); + pragma Assert (Present (Edge)); + pragma Assert (LGV_Sets.Present (All_Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (All_Waiting_Vertices)); + pragma Assert (LGV_Sets.Present (Comp_Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (Comp_Waiting_Vertices)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, Edge); + Succ : constant Library_Graph_Vertex_Id := Successor (G, Edge); + pragma Assert (Needs_Elaboration (G, Pred)); - pragma Assert (Present (Succ)); pragma Assert (Needs_Elaboration (G, Succ)); - pragma Assert (Present (All_Candidates)); - pragma Assert (Present (Comp_Candidates)); - Pred_Comp : constant Component_Id := Component (G, Pred); - Succ_Comp : constant Component_Id := Component (G, Succ); + In_Different_Components : constant Boolean := + not In_Same_Component + (G => G, + Left => Pred, + Right => Succ); - pragma Assert (Present (Pred_Comp)); - pragma Assert (Present (Succ_Comp)); + Succ_Comp : constant Component_Id := Component (G, Succ); + Vertex_Indent : constant Indentation_Level := + Indent + Nested_Indentation; - In_Different_Components : constant Boolean := Pred_Comp /= Succ_Comp; - - Candidate : Library_Graph_Vertex_Id; - Iter : Component_Vertex_Iterator; - Msg : String_Ptr; - Set : Membership_Set; + Iter : Component_Vertex_Iterator; + Vertex : Library_Graph_Vertex_Id; begin Trace_Vertex (G => G, - LGV_Id => Succ, + Vertex => Succ, Msg => "updating successor", Step => Step, Indent => Indent); @@ -1308,45 +1566,61 @@ package body Bindo.Elaborators is -- Notify the successor that it has one less predecessor to wait on. -- This effectively eliminates the edge that links the two. - Decrement_Pending_Predecessors (G, Succ); + Decrement_Pending_Predecessors + (G => G, + Vertex => Succ, + Edge => Edge); -- The predecessor and successor reside in different components. -- Notify the successor component it has one fewer components to -- wait on. if In_Different_Components then - Decrement_Pending_Predecessors (G, Succ_Comp); + Decrement_Pending_Predecessors + (G => G, + Comp => Succ_Comp, + Edge => Edge); end if; -- At this point the successor may become elaborable when its final - -- predecessor or final predecessor component is elaborated. - - -- The predecessor and successor reside in different components. - -- The successor must not be added to the candidates of Pred's - -- component because this will mix units from the two components. - -- Instead, the successor is added to the set of all candidates - -- that must be elaborated. - - if In_Different_Components then - Msg := Add_To_All_Candidates_Msg'Access; - Set := All_Candidates; - - -- Otherwise the predecessor and successor reside within the same - -- component. Pred's component gains another elaborable node. + -- predecessor or final predecessor component has been elaborated. + + if Is_Elaborable_Vertex (G, Succ) then + + -- The predecessor and successor reside in different components. + -- The successor must not be added to the candidates of Pred's + -- component because this will mix units from the two components. + -- Instead, the successor is added to the set of all elaborable + -- vertices. + + if In_Different_Components then + Insert_Elaborable_Successor + (G => G, + Vertex => Succ, + Elaborable_Vertices => All_Elaborable_Vertices, + All_Waiting_Vertices => All_Waiting_Vertices, + Comp_Waiting_Vertices => Comp_Waiting_Vertices, + Msg => "add elaborable successor", + Step => Step, + Indent => Vertex_Indent); + + -- Otherwise the predecessor and successor reside within the same + -- component. Pred's component gains another elaborable vertex. - else - Msg := Add_To_Comp_Candidates_Msg'Access; - Set := Comp_Candidates; + else + Insert_Elaborable_Successor + (G => G, + Vertex => Succ, + Elaborable_Vertices => Comp_Elaborable_Vertices, + All_Waiting_Vertices => All_Waiting_Vertices, + Comp_Waiting_Vertices => Comp_Waiting_Vertices, + Msg => + "add elaborable component successor", + Step => Step, + Indent => Vertex_Indent); + end if; end if; - Add_Vertex_If_Elaborable - (G => G, - LGV_Id => Succ, - Set => Set, - Msg => Msg.all, - Step => Step, - Indent => Indent + Nested_Indentation); - -- At this point the successor component may become elaborable when -- its final predecessor component is elaborated. This in turn may -- allow vertices of the successor component to be elaborated. @@ -1356,16 +1630,19 @@ package body Bindo.Elaborators is then Iter := Iterate_Component_Vertices (G, Succ_Comp); while Has_Next (Iter) loop - Next (Iter, Candidate); - pragma Assert (Present (Candidate)); - - Add_Vertex_If_Elaborable - (G => G, - LGV_Id => Candidate, - Set => All_Candidates, - Msg => Add_To_All_Candidates_Msg, - Step => Step, - Indent => Indent + Nested_Indentation); + Next (Iter, Vertex); + + if Is_Elaborable_Vertex (G, Vertex) then + Insert_Elaborable_Successor + (G => G, + Vertex => Vertex, + Elaborable_Vertices => All_Elaborable_Vertices, + All_Waiting_Vertices => All_Waiting_Vertices, + Comp_Waiting_Vertices => Comp_Waiting_Vertices, + Msg => "add elaborable vertex", + Step => Step, + Indent => Vertex_Indent); + end if; end loop; end if; end Update_Successor; @@ -1375,42 +1652,41 @@ package body Bindo.Elaborators is ----------------------- procedure Update_Successors - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - All_Candidates : Membership_Set; - Comp_Candidates : Membership_Set; - Step : Elaboration_Order_Step; - Indent : Indentation_Level) + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + All_Elaborable_Vertices : LGV_Sets.Membership_Set; + All_Waiting_Vertices : LGV_Sets.Membership_Set; + Comp_Elaborable_Vertices : LGV_Sets.Membership_Set; + Comp_Waiting_Vertices : LGV_Sets.Membership_Set; + Step : Elaboration_Order_Step; + Indent : Indentation_Level) is - Iter : Edges_To_Successors_Iterator; - LGE_Id : Library_Graph_Edge_Id; - Succ : Library_Graph_Vertex_Id; + Edge : Library_Graph_Edge_Id; + Iter : Edges_To_Successors_Iterator; begin pragma Assert (Present (G)); - pragma Assert (Present (Pred)); - pragma Assert (Needs_Elaboration (G, Pred)); - pragma Assert (Present (All_Candidates)); - pragma Assert (Present (Comp_Candidates)); - - Iter := Iterate_Edges_To_Successors (G, Pred); + pragma Assert (Present (Vertex)); + pragma Assert (Needs_Elaboration (G, Vertex)); + pragma Assert (LGV_Sets.Present (All_Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (All_Waiting_Vertices)); + pragma Assert (LGV_Sets.Present (Comp_Elaborable_Vertices)); + pragma Assert (LGV_Sets.Present (Comp_Waiting_Vertices)); + + Iter := Iterate_Edges_To_Successors (G, Vertex); while Has_Next (Iter) loop - Next (Iter, LGE_Id); - - pragma Assert (Present (LGE_Id)); - pragma Assert (Predecessor (G, LGE_Id) = Pred); - - Succ := Successor (G, LGE_Id); - pragma Assert (Present (Succ)); + Next (Iter, Edge); + pragma Assert (Predecessor (G, Edge) = Vertex); Update_Successor - (G => G, - Pred => Pred, - Succ => Succ, - All_Candidates => All_Candidates, - Comp_Candidates => Comp_Candidates, - Step => Step, - Indent => Indent); + (G => G, + Edge => Edge, + All_Elaborable_Vertices => All_Elaborable_Vertices, + All_Waiting_Vertices => All_Waiting_Vertices, + Comp_Elaborable_Vertices => Comp_Elaborable_Vertices, + Comp_Waiting_Vertices => Comp_Waiting_Vertices, + Step => Step, + Indent => Indent); end loop; end Update_Successors; end Invocation_And_Library_Graph_Elaborators; diff --git a/gcc/ada/bindo-graphs.adb b/gcc/ada/bindo-graphs.adb index b2f458c..c2f9d6c 100644 --- a/gcc/ada/bindo-graphs.adb +++ b/gcc/ada/bindo-graphs.adb @@ -25,7 +25,13 @@ with Ada.Unchecked_Deallocation; -with GNAT.Lists; use GNAT.Lists; +with Butil; use Butil; +with Debug; use Debug; +with Output; use Output; + +with Bindo.Writers; +use Bindo.Writers; +use Bindo.Writers.Phase_Writers; package body Bindo.Graphs is @@ -33,33 +39,85 @@ package body Bindo.Graphs is -- Local subprograms -- ----------------------- - function Sequence_Next_IGE_Id return Invocation_Graph_Edge_Id; - pragma Inline (Sequence_Next_IGE_Id); - -- Generate a new unique invocation graph edge handle + function Sequence_Next_Cycle return Library_Graph_Cycle_Id; + pragma Inline (Sequence_Next_Cycle); + -- Generate a new unique library graph cycle handle - function Sequence_Next_IGV_Id return Invocation_Graph_Vertex_Id; - pragma Inline (Sequence_Next_IGV_Id); - -- Generate a new unique invocation graph vertex handle + function Sequence_Next_Edge return Invocation_Graph_Edge_Id; + pragma Inline (Sequence_Next_Edge); + -- Generate a new unique invocation graph edge handle - function Sequence_Next_LGE_Id return Library_Graph_Edge_Id; - pragma Inline (Sequence_Next_LGE_Id); + function Sequence_Next_Edge return Library_Graph_Edge_Id; + pragma Inline (Sequence_Next_Edge); -- Generate a new unique library graph edge handle - function Sequence_Next_LGV_Id return Library_Graph_Vertex_Id; - pragma Inline (Sequence_Next_LGV_Id); + function Sequence_Next_Vertex return Invocation_Graph_Vertex_Id; + pragma Inline (Sequence_Next_Vertex); + -- Generate a new unique invocation graph vertex handle + + function Sequence_Next_Vertex return Library_Graph_Vertex_Id; + pragma Inline (Sequence_Next_Vertex); -- Generate a new unique library graph vertex handle + ----------------------------------- + -- Destroy_Invocation_Graph_Edge -- + ----------------------------------- + + procedure Destroy_Invocation_Graph_Edge + (Edge : in out Invocation_Graph_Edge_Id) + is + pragma Unreferenced (Edge); + begin + null; + end Destroy_Invocation_Graph_Edge; + + --------------------------------- + -- Destroy_Library_Graph_Cycle -- + --------------------------------- + + procedure Destroy_Library_Graph_Cycle + (Cycle : in out Library_Graph_Cycle_Id) + is + pragma Unreferenced (Cycle); + begin + null; + end Destroy_Library_Graph_Cycle; + + -------------------------------- + -- Destroy_Library_Graph_Edge -- + -------------------------------- + + procedure Destroy_Library_Graph_Edge + (Edge : in out Library_Graph_Edge_Id) + is + pragma Unreferenced (Edge); + begin + null; + end Destroy_Library_Graph_Edge; + + ---------------------------------- + -- Destroy_Library_Graph_Vertex -- + ---------------------------------- + + procedure Destroy_Library_Graph_Vertex + (Vertex : in out Library_Graph_Vertex_Id) + is + pragma Unreferenced (Vertex); + begin + null; + end Destroy_Library_Graph_Vertex; + -------------------------------- -- Hash_Invocation_Graph_Edge -- -------------------------------- function Hash_Invocation_Graph_Edge - (IGE_Id : Invocation_Graph_Edge_Id) return Bucket_Range_Type + (Edge : Invocation_Graph_Edge_Id) return Bucket_Range_Type is begin - pragma Assert (Present (IGE_Id)); + pragma Assert (Present (Edge)); - return Bucket_Range_Type (IGE_Id); + return Bucket_Range_Type (Edge); end Hash_Invocation_Graph_Edge; ---------------------------------- @@ -67,25 +125,38 @@ package body Bindo.Graphs is ---------------------------------- function Hash_Invocation_Graph_Vertex - (IGV_Id : Invocation_Graph_Vertex_Id) return Bucket_Range_Type + (Vertex : Invocation_Graph_Vertex_Id) return Bucket_Range_Type is begin - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); - return Bucket_Range_Type (IGV_Id); + return Bucket_Range_Type (Vertex); end Hash_Invocation_Graph_Vertex; + ------------------------------ + -- Hash_Library_Graph_Cycle -- + ------------------------------ + + function Hash_Library_Graph_Cycle + (Cycle : Library_Graph_Cycle_Id) return Bucket_Range_Type + is + begin + pragma Assert (Present (Cycle)); + + return Bucket_Range_Type (Cycle); + end Hash_Library_Graph_Cycle; + ----------------------------- -- Hash_Library_Graph_Edge -- ----------------------------- function Hash_Library_Graph_Edge - (LGE_Id : Library_Graph_Edge_Id) return Bucket_Range_Type + (Edge : Library_Graph_Edge_Id) return Bucket_Range_Type is begin - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Edge)); - return Bucket_Range_Type (LGE_Id); + return Bucket_Range_Type (Edge); end Hash_Library_Graph_Edge; ------------------------------- @@ -93,12 +164,12 @@ package body Bindo.Graphs is ------------------------------- function Hash_Library_Graph_Vertex - (LGV_Id : Library_Graph_Vertex_Id) return Bucket_Range_Type + (Vertex : Library_Graph_Vertex_Id) return Bucket_Range_Type is begin - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - return Bucket_Range_Type (LGV_Id); + return Bucket_Range_Type (Vertex); end Hash_Library_Graph_Vertex; ----------------------- @@ -116,18 +187,18 @@ package body Bindo.Graphs is (Invocation_Graph_Attributes, Invocation_Graph); function Get_IGE_Attributes - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Edge_Attributes; pragma Inline (Get_IGE_Attributes); - -- Obtain the attributes of edge IGE_Id of invocation graph G + -- Obtain the attributes of edge Edge of invocation graph G function Get_IGV_Attributes (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) + Vertex : Invocation_Graph_Vertex_Id) return Invocation_Graph_Vertex_Attributes; pragma Inline (Get_IGV_Attributes); - -- Obtain the attributes of vertex IGV_Id of invocation graph G + -- Obtain the attributes of vertex Vertex of invocation graph G procedure Increment_Invocation_Graph_Edge_Count (G : Invocation_Graph; @@ -138,16 +209,16 @@ package body Bindo.Graphs is function Is_Elaboration_Root (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Boolean; + Vertex : Invocation_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Elaboration_Root); - -- Determine whether vertex IGV_Id of invocation graph denotes the + -- Determine whether vertex Vertex of invocation graph denotes the -- elaboration procedure of a spec or a body. function Is_Existing_Source_Target_Relation (G : Invocation_Graph; Rel : Source_Target_Relation) return Boolean; pragma Inline (Is_Existing_Source_Target_Relation); - -- Determine whether a source vertex and a target vertex desctibed by + -- Determine whether a source vertex and a target vertex described by -- relation Rel are already related in invocation graph G. procedure Save_Elaboration_Root @@ -159,31 +230,31 @@ package body Bindo.Graphs is procedure Set_Corresponding_Vertex (G : Invocation_Graph; IS_Id : Invocation_Signature_Id; - IGV_Id : Invocation_Graph_Vertex_Id); + Vertex : Invocation_Graph_Vertex_Id); pragma Inline (Set_Corresponding_Vertex); - -- Associate vertex IGV_Id of invocation graph G with signature IS_Id + -- Associate vertex Vertex of invocation graph G with signature IS_Id procedure Set_Is_Existing_Source_Target_Relation (G : Invocation_Graph; Rel : Source_Target_Relation; Val : Boolean := True); pragma Inline (Set_Is_Existing_Source_Target_Relation); - -- Mark a source vertex and a target vertex desctibed by relation Rel as + -- Mark a source vertex and a target vertex described by relation Rel as -- already related in invocation graph G depending on value Val. procedure Set_IGE_Attributes - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id; - Val : Invocation_Graph_Edge_Attributes); + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id; + Val : Invocation_Graph_Edge_Attributes); pragma Inline (Set_IGE_Attributes); - -- Set the attributes of edge IGE_Id of invocation graph G to value Val + -- Set the attributes of edge Edge of invocation graph G to value Val procedure Set_IGV_Attributes (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id; + Vertex : Invocation_Graph_Vertex_Id; Val : Invocation_Graph_Vertex_Attributes); pragma Inline (Set_IGV_Attributes); - -- Set the attributes of vertex IGV_Id of invocation graph G to value + -- Set the attributes of vertex Vertex of invocation graph G to value -- Val. -------------- @@ -205,10 +276,7 @@ package body Bindo.Graphs is (Source => Source, Target => Target); - IR_Rec : Invocation_Relation_Record renames - Invocation_Relations.Table (IR_Id); - - IGE_Id : Invocation_Graph_Edge_Id; + Edge : Invocation_Graph_Edge_Id; begin -- Nothing to do when the source and target are already related by an @@ -218,22 +286,22 @@ package body Bindo.Graphs is return; end if; - IGE_Id := Sequence_Next_IGE_Id; + Edge := Sequence_Next_Edge; -- Add the edge to the underlying graph DG.Add_Edge (G => G.Graph, - E => IGE_Id, + E => Edge, Source => Source, Destination => Target); -- Build and save the attributes of the edge Set_IGE_Attributes - (G => G, - IGE_Id => IGE_Id, - Val => (Relation => IR_Id)); + (G => G, + Edge => Edge, + Val => (Relation => IR_Id)); -- Mark the source and target as related by the new edge. This -- prevents all further attempts to link the same source and target. @@ -242,7 +310,7 @@ package body Bindo.Graphs is -- Update the edge statistics - Increment_Invocation_Graph_Edge_Count (G, IR_Rec.Kind); + Increment_Invocation_Graph_Edge_Count (G, Kind (IR_Id)); end Add_Edge; ---------------- @@ -250,67 +318,97 @@ package body Bindo.Graphs is ---------------- procedure Add_Vertex - (G : Invocation_Graph; - IC_Id : Invocation_Construct_Id; - LGV_Id : Library_Graph_Vertex_Id) + (G : Invocation_Graph; + IC_Id : Invocation_Construct_Id; + Body_Vertex : Library_Graph_Vertex_Id; + Spec_Vertex : Library_Graph_Vertex_Id) is pragma Assert (Present (G)); pragma Assert (Present (IC_Id)); - pragma Assert (Present (LGV_Id)); - - IC_Rec : Invocation_Construct_Record renames - Invocation_Constructs.Table (IC_Id); - - pragma Assert (Present (IC_Rec.Signature)); + pragma Assert (Present (Body_Vertex)); + pragma Assert (Present (Spec_Vertex)); - IGV_Id : Invocation_Graph_Vertex_Id; + Construct_Signature : constant Invocation_Signature_Id := + Signature (IC_Id); + Vertex : Invocation_Graph_Vertex_Id; begin -- Nothing to do when the construct already has a vertex - if Present (Corresponding_Vertex (G, IC_Rec.Signature)) then + if Present (Corresponding_Vertex (G, Construct_Signature)) then return; end if; - IGV_Id := Sequence_Next_IGV_Id; + Vertex := Sequence_Next_Vertex; -- Add the vertex to the underlying graph - DG.Add_Vertex (G.Graph, IGV_Id); + DG.Add_Vertex (G.Graph, Vertex); -- Build and save the attributes of the vertex Set_IGV_Attributes (G => G, - IGV_Id => IGV_Id, - Val => (Construct => IC_Id, - Lib_Vertex => LGV_Id)); + Vertex => Vertex, + Val => (Body_Vertex => Body_Vertex, + Construct => IC_Id, + Spec_Vertex => Spec_Vertex)); -- Associate the construct with its corresponding vertex - Set_Corresponding_Vertex (G, IC_Rec.Signature, IGV_Id); + Set_Corresponding_Vertex (G, Construct_Signature, Vertex); -- Save the vertex for later processing when it denotes a spec or -- body elaboration procedure. - if Is_Elaboration_Root (G, IGV_Id) then - Save_Elaboration_Root (G, IGV_Id); + if Is_Elaboration_Root (G, Vertex) then + Save_Elaboration_Root (G, Vertex); end if; end Add_Vertex; + ----------------- + -- Body_Vertex -- + ----------------- + + function Body_Vertex + (G : Invocation_Graph; + Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return Get_IGV_Attributes (G, Vertex).Body_Vertex; + end Body_Vertex; + + ------------ + -- Column -- + ------------ + + function Column + (G : Invocation_Graph; + Vertex : Invocation_Graph_Vertex_Id) return Nat + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return Column (Signature (Construct (G, Vertex))); + end Column; + --------------- -- Construct -- --------------- function Construct (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id + Vertex : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); - return Get_IGV_Attributes (G, IGV_Id).Construct; + return Get_IGV_Attributes (G, Vertex).Construct; end Construct; -------------------------- @@ -325,7 +423,7 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (IS_Id)); - return SV.Get (G.Signature_To_Vertex, IS_Id); + return Signature_Tables.Get (G.Signature_To_Vertex, IS_Id); end Corresponding_Vertex; ------------ @@ -339,15 +437,15 @@ package body Bindo.Graphs is G : constant Invocation_Graph := new Invocation_Graph_Attributes; begin - G.Edge_Attributes := EA.Create (Initial_Edges); + G.Edge_Attributes := IGE_Tables.Create (Initial_Edges); G.Graph := DG.Create (Initial_Vertices => Initial_Vertices, Initial_Edges => Initial_Edges); - G.Relations := ST.Create (Initial_Edges); - G.Roots := ER.Create (Initial_Vertices); - G.Signature_To_Vertex := SV.Create (Initial_Vertices); - G.Vertex_Attributes := VA.Create (Initial_Vertices); + G.Relations := Relation_Sets.Create (Initial_Edges); + G.Roots := IGV_Sets.Create (Initial_Vertices); + G.Signature_To_Vertex := Signature_Tables.Create (Initial_Vertices); + G.Vertex_Attributes := IGV_Tables.Create (Initial_Vertices); return G; end Create; @@ -360,12 +458,12 @@ package body Bindo.Graphs is begin pragma Assert (Present (G)); - EA.Destroy (G.Edge_Attributes); - DG.Destroy (G.Graph); - ST.Destroy (G.Relations); - ER.Destroy (G.Roots); - SV.Destroy (G.Signature_To_Vertex); - VA.Destroy (G.Vertex_Attributes); + IGE_Tables.Destroy (G.Edge_Attributes); + DG.Destroy (G.Graph); + Relation_Sets.Destroy (G.Relations); + IGV_Sets.Destroy (G.Roots); + Signature_Tables.Destroy (G.Signature_To_Vertex); + IGV_Tables.Destroy (G.Vertex_Attributes); Free (G); end Destroy; @@ -375,9 +473,9 @@ package body Bindo.Graphs is ----------------------------------- procedure Destroy_Invocation_Graph_Edge - (IGE_Id : in out Invocation_Graph_Edge_Id) + (Edge : in out Invocation_Graph_Edge_Id) is - pragma Unreferenced (IGE_Id); + pragma Unreferenced (Edge); begin null; end Destroy_Invocation_Graph_Edge; @@ -399,9 +497,9 @@ package body Bindo.Graphs is ------------------------------------- procedure Destroy_Invocation_Graph_Vertex - (IGV_Id : in out Invocation_Graph_Vertex_Id) + (Vertex : in out Invocation_Graph_Vertex_Id) is - pragma Unreferenced (IGV_Id); + pragma Unreferenced (Vertex); begin null; end Destroy_Invocation_Graph_Vertex; @@ -418,20 +516,35 @@ package body Bindo.Graphs is null; end Destroy_Invocation_Graph_Vertex_Attributes; + ----------- + -- Extra -- + ----------- + + function Extra + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Name_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return Extra (Relation (G, Edge)); + end Extra; + ------------------------ -- Get_IGE_Attributes -- ------------------------ function Get_IGE_Attributes - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Edge_Attributes is begin pragma Assert (Present (G)); - pragma Assert (Present (IGE_Id)); + pragma Assert (Present (Edge)); - return EA.Get (G.Edge_Attributes, IGE_Id); + return IGE_Tables.Get (G.Edge_Attributes, Edge); end Get_IGE_Attributes; ------------------------ @@ -440,14 +553,14 @@ package body Bindo.Graphs is function Get_IGV_Attributes (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) + Vertex : Invocation_Graph_Vertex_Id) return Invocation_Graph_Vertex_Attributes is begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); - return VA.Get (G.Vertex_Attributes, IGV_Id); + return IGV_Tables.Get (G.Vertex_Attributes, Vertex); end Get_IGV_Attributes; -------------- @@ -483,7 +596,7 @@ package body Bindo.Graphs is function Has_Next (Iter : Elaboration_Root_Iterator) return Boolean is begin - return ER.Has_Next (ER.Iterator (Iter)); + return IGV_Sets.Has_Next (IGV_Sets.Iterator (Iter)); end Has_Next; ------------------------------- @@ -552,23 +665,19 @@ package body Bindo.Graphs is function Is_Elaboration_Root (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Boolean + Vertex : Invocation_Graph_Vertex_Id) return Boolean is pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); - - IC_Id : constant Invocation_Construct_Id := Construct (G, IGV_Id); - - pragma Assert (Present (IC_Id)); + pragma Assert (Present (Vertex)); - IC_Rec : Invocation_Construct_Record renames - Invocation_Constructs.Table (IC_Id); + Vertex_Kind : constant Invocation_Construct_Kind := + Kind (Construct (G, Vertex)); begin return - IC_Rec.Kind = Elaborate_Body_Procedure + Vertex_Kind = Elaborate_Body_Procedure or else - IC_Rec.Kind = Elaborate_Spec_Procedure; + Vertex_Kind = Elaborate_Spec_Procedure; end Is_Elaboration_Root; ---------------------------------------- @@ -582,7 +691,7 @@ package body Bindo.Graphs is begin pragma Assert (Present (G)); - return ST.Contains (G.Relations, Rel); + return Relation_Sets.Contains (G.Relations, Rel); end Is_Existing_Source_Target_Relation; ----------------------- @@ -617,15 +726,15 @@ package body Bindo.Graphs is function Iterate_Edges_To_Targets (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator + Vertex : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator is begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); return Edges_To_Targets_Iterator - (DG.Iterate_Outgoing_Edges (G.Graph, IGV_Id)); + (DG.Iterate_Outgoing_Edges (G.Graph, Vertex)); end Iterate_Edges_To_Targets; ------------------------------- @@ -638,7 +747,7 @@ package body Bindo.Graphs is begin pragma Assert (Present (G)); - return Elaboration_Root_Iterator (ER.Iterate (G.Roots)); + return Elaboration_Root_Iterator (IGV_Sets.Iterate (G.Roots)); end Iterate_Elaboration_Roots; ---------- @@ -646,37 +755,30 @@ package body Bindo.Graphs is ---------- function Kind - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Kind + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Invocation_Kind is + begin pragma Assert (Present (G)); - pragma Assert (Present (IGE_Id)); + pragma Assert (Present (Edge)); - IR_Id : constant Invocation_Relation_Id := Relation (G, IGE_Id); - - pragma Assert (Present (IR_Id)); - - IR_Rec : Invocation_Relation_Record renames - Invocation_Relations.Table (IR_Id); - - begin - return IR_Rec.Kind; + return Kind (Relation (G, Edge)); end Kind; - ---------------- - -- Lib_Vertex -- - ---------------- + ---------- + -- Line -- + ---------- - function Lib_Vertex + function Line (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id + Vertex : Invocation_Graph_Vertex_Id) return Nat is begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); - return Get_IGV_Attributes (G, IGV_Id).Lib_Vertex; - end Lib_Vertex; + return Line (Signature (Construct (G, Vertex))); + end Line; ---------- -- Name -- @@ -684,25 +786,13 @@ package body Bindo.Graphs is function Name (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Name_Id + Vertex : Invocation_Graph_Vertex_Id) return Name_Id is + begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); - - IC_Id : constant Invocation_Construct_Id := Construct (G, IGV_Id); - - pragma Assert (Present (IC_Id)); - - IC_Rec : Invocation_Construct_Record renames - Invocation_Constructs.Table (IC_Id); - - pragma Assert (Present (IC_Rec.Signature)); - - IS_Rec : Invocation_Signature_Record renames - Invocation_Signatures.Table (IC_Rec.Signature); + pragma Assert (Present (Vertex)); - begin - return IS_Rec.Name; + return Name (Signature (Construct (G, Vertex))); end Name; ---------- @@ -710,11 +800,11 @@ package body Bindo.Graphs is ---------- procedure Next - (Iter : in out All_Edge_Iterator; - IGE_Id : out Invocation_Graph_Edge_Id) + (Iter : in out All_Edge_Iterator; + Edge : out Invocation_Graph_Edge_Id) is begin - DG.Next (DG.All_Edge_Iterator (Iter), IGE_Id); + DG.Next (DG.All_Edge_Iterator (Iter), Edge); end Next; ---------- @@ -723,10 +813,10 @@ package body Bindo.Graphs is procedure Next (Iter : in out All_Vertex_Iterator; - IGV_Id : out Invocation_Graph_Vertex_Id) + Vertex : out Invocation_Graph_Vertex_Id) is begin - DG.Next (DG.All_Vertex_Iterator (Iter), IGV_Id); + DG.Next (DG.All_Vertex_Iterator (Iter), Vertex); end Next; ---------- @@ -734,11 +824,11 @@ package body Bindo.Graphs is ---------- procedure Next - (Iter : in out Edges_To_Targets_Iterator; - IGE_Id : out Invocation_Graph_Edge_Id) + (Iter : in out Edges_To_Targets_Iterator; + Edge : out Invocation_Graph_Edge_Id) is begin - DG.Next (DG.Outgoing_Edge_Iterator (Iter), IGE_Id); + DG.Next (DG.Outgoing_Edge_Iterator (Iter), Edge); end Next; ---------- @@ -750,7 +840,7 @@ package body Bindo.Graphs is Root : out Invocation_Graph_Vertex_Id) is begin - ER.Next (ER.Iterator (Iter), Root); + IGV_Sets.Next (IGV_Sets.Iterator (Iter), Root); end Next; --------------------- @@ -770,13 +860,13 @@ package body Bindo.Graphs is function Number_Of_Edges_To_Targets (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Natural + Vertex : Invocation_Graph_Vertex_Id) return Natural is begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); - return DG.Number_Of_Outgoing_Edges (G.Graph, IGV_Id); + return DG.Number_Of_Outgoing_Edges (G.Graph, Vertex); end Number_Of_Edges_To_Targets; --------------------------------- @@ -789,7 +879,7 @@ package body Bindo.Graphs is begin pragma Assert (Present (G)); - return ER.Size (G.Roots); + return IGV_Sets.Size (G.Roots); end Number_Of_Elaboration_Roots; ------------------------ @@ -817,14 +907,14 @@ package body Bindo.Graphs is -------------- function Relation - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Relation_Id + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Invocation_Relation_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (IGE_Id)); + pragma Assert (Present (Edge)); - return Get_IGE_Attributes (G, IGE_Id).Relation; + return Get_IGE_Attributes (G, Edge).Relation; end Relation; --------------------------- @@ -839,7 +929,7 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (Root)); - ER.Insert (G.Roots, Root); + IGV_Sets.Insert (G.Roots, Root); end Save_Elaboration_Root; ------------------------------ @@ -849,14 +939,14 @@ package body Bindo.Graphs is procedure Set_Corresponding_Vertex (G : Invocation_Graph; IS_Id : Invocation_Signature_Id; - IGV_Id : Invocation_Graph_Vertex_Id) + Vertex : Invocation_Graph_Vertex_Id) is begin pragma Assert (Present (G)); pragma Assert (Present (IS_Id)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); - SV.Put (G.Signature_To_Vertex, IS_Id, IGV_Id); + Signature_Tables.Put (G.Signature_To_Vertex, IS_Id, Vertex); end Set_Corresponding_Vertex; -------------------------------------------- @@ -874,9 +964,9 @@ package body Bindo.Graphs is pragma Assert (Present (Rel.Target)); if Val then - ST.Insert (G.Relations, Rel); + Relation_Sets.Insert (G.Relations, Rel); else - ST.Delete (G.Relations, Rel); + Relation_Sets.Delete (G.Relations, Rel); end if; end Set_Is_Existing_Source_Target_Relation; @@ -885,15 +975,15 @@ package body Bindo.Graphs is ------------------------ procedure Set_IGE_Attributes - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id; - Val : Invocation_Graph_Edge_Attributes) + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id; + Val : Invocation_Graph_Edge_Attributes) is begin pragma Assert (Present (G)); - pragma Assert (Present (IGE_Id)); + pragma Assert (Present (Edge)); - EA.Put (G.Edge_Attributes, IGE_Id, Val); + IGE_Tables.Put (G.Edge_Attributes, Edge, Val); end Set_IGE_Attributes; ------------------------ @@ -902,29 +992,44 @@ package body Bindo.Graphs is procedure Set_IGV_Attributes (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id; + Vertex : Invocation_Graph_Vertex_Id; Val : Invocation_Graph_Vertex_Attributes) is begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); - VA.Put (G.Vertex_Attributes, IGV_Id, Val); + IGV_Tables.Put (G.Vertex_Attributes, Vertex, Val); end Set_IGV_Attributes; + ----------------- + -- Spec_Vertex -- + ----------------- + + function Spec_Vertex + (G : Invocation_Graph; + Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return Get_IGV_Attributes (G, Vertex).Spec_Vertex; + end Spec_Vertex; + ------------ -- Target -- ------------ function Target (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id + Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (IGE_Id)); + pragma Assert (Present (Edge)); - return DG.Destination_Vertex (G.Graph, IGE_Id); + return DG.Destination_Vertex (G.Graph, Edge); end Target; end Invocation_Graphs; @@ -934,46 +1039,95 @@ package body Bindo.Graphs is package body Library_Graphs is - --------------- - -- Edge list -- - --------------- - - package EL is new Doubly_Linked_Lists - (Element_Type => Library_Graph_Edge_Id, - "=" => "=", - Destroy_Element => Destroy_Library_Graph_Edge); - ----------------------- -- Local subprograms -- ----------------------- procedure Add_Body_Before_Spec_Edge (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Edges : EL.Doubly_Linked_List); + Vertex : Library_Graph_Vertex_Id; + Edges : LGE_Lists.Doubly_Linked_List); pragma Inline (Add_Body_Before_Spec_Edge); - -- Create a new edge in library graph G between vertex LGV_Id and its + -- Create a new edge in library graph G between vertex Vertex and its -- corresponding spec or body, where the body is a predecessor and the -- spec a successor. Add the edge to list Edges. procedure Add_Body_Before_Spec_Edges (G : Library_Graph; - Edges : EL.Doubly_Linked_List); + Edges : LGE_Lists.Doubly_Linked_List); pragma Inline (Add_Body_Before_Spec_Edges); -- Create new edges in library graph G for all vertices and their -- corresponding specs or bodies, where the body is a predecessor -- and the spec is a successor. Add all edges to list Edges. function Add_Edge_With_Return - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - Succ : Library_Graph_Vertex_Id; - Kind : Library_Graph_Edge_Kind) return Library_Graph_Edge_Id; + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind; + Activates_Task : Boolean) return Library_Graph_Edge_Id; pragma Inline (Add_Edge_With_Return); -- Create a new edge in library graph G with source vertex Pred and -- destination vertex Succ, and return its handle. Kind denotes the - -- nature of the edge. If Pred and Succ are already related, no edge - -- is created and No_Library_Graph_Edge is returned. + -- nature of the edge. Activates_Task should be set when the edge + -- involves a task activation. If Pred and Succ are already related, + -- no edge is created and No_Library_Graph_Edge is returned. + + function At_Least_One_Edge_Satisfies + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Predicate : LGE_Predicate_Ptr) return Boolean; + pragma Inline (At_Least_One_Edge_Satisfies); + -- Determine whether at least one edge of cycle Cycle of library graph G + -- satisfies predicate Predicate. + + function Copy_Cycle_Path + (Cycle_Path : LGE_Lists.Doubly_Linked_List) + return LGE_Lists.Doubly_Linked_List; + pragma Inline (Copy_Cycle_Path); + -- Create a deep copy of list Cycle_Path + + function Cycle_End_Vertices + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean) return LGV_Sets.Membership_Set; + pragma Inline (Cycle_End_Vertices); + -- Part of Tarjan's enumeration of the elementary circuits of a directed + -- graph algorithm. Collect the vertices that terminate a cycle starting + -- from vertex Vertex of library graph G in a set. This is usually the + -- vertex itself, unless the vertex is part of an Elaborate_Body pair, + -- or flag Elaborate_All_Active is set. In that case the complementary + -- vertex is also added to the set. + + function Cycle_Kind_Of + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Cycle_Kind; + pragma Inline (Cycle_Kind_Of); + -- Determine the cycle kind of edge Edge of library graph G if the edge + -- participated in a circuit. + + function Cycle_Kind_Precedence + (Kind : Library_Graph_Cycle_Kind; + Compared_To : Library_Graph_Cycle_Kind) return Precedence_Kind; + pragma Inline (Cycle_Kind_Precedence); + -- Determine the precedence of cycle kind Kind compared to cycle kind + -- Compared_To. + + function Cycle_Path_Precedence + (G : Library_Graph; + Path : LGE_Lists.Doubly_Linked_List; + Compared_To : LGE_Lists.Doubly_Linked_List) return Precedence_Kind; + pragma Inline (Cycle_Path_Precedence); + -- Determine the precedence of cycle path Path of library graph G + -- compared to path Compared_To. + + function Cycle_Precedence + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Compared_To : Library_Graph_Cycle_Id) return Precedence_Kind; + pragma Inline (Cycle_Precedence); + -- Determine the precedence of cycle Cycle of library graph G compared + -- to cycle Compared_To. procedure Decrement_Library_Graph_Edge_Count (G : Library_Graph; @@ -983,7 +1137,7 @@ package body Bindo.Graphs is procedure Delete_Body_Before_Spec_Edges (G : Library_Graph; - Edges : EL.Doubly_Linked_List); + Edges : LGE_Lists.Doubly_Linked_List); pragma Inline (Delete_Body_Before_Spec_Edges); -- Delete all edges in list Edges from library graph G, that link spec -- and bodies, where the body acts as the predecessor and the spec as a @@ -991,9 +1145,145 @@ package body Bindo.Graphs is procedure Delete_Edge (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id); + Edge : Library_Graph_Edge_Id); pragma Inline (Delete_Edge); - -- Delete edge LGE_Id from library graph G + -- Delete edge Edge from library graph G + + function Edge_Precedence + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + Compared_To : Library_Graph_Edge_Id) return Precedence_Kind; + pragma Inline (Edge_Precedence); + -- Determine the precedence of edge Edge of library graph G compared to + -- edge Compared_To. + + procedure Find_Cycles_From_Successor + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + End_Vertices : LGV_Sets.Membership_Set; + Deleted_Vertices : LGV_Sets.Membership_Set; + Most_Significant_Edge : Library_Graph_Edge_Id; + Invocation_Edge_Count : Natural; + Cycle_Path_Stack : LGE_Lists.Doubly_Linked_List; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List; + Cycle_Count : in out Natural; + Cycle_Limit : Natural; + Elaborate_All_Active : Boolean; + Has_Cycle : out Boolean; + Indent : Indentation_Level); + pragma Inline (Find_Cycles_From_Successor); + -- Part of Tarjan's enumeration of the elementary circuits of a directed + -- graph algorithm. Find all cycles from the successor indicated by edge + -- Edge of library graph G. If at least one cycle exists, set Has_Cycle + -- to True. The remaining parameters are as follows: + -- + -- * End vertices is the set of vertices that terminate a potential + -- cycle. + -- + -- * Deleted vertices is the set of vertices that have been expanded + -- during previous depth-first searches and should not be visited + -- for the rest of the algorithm. + -- + -- * Most_Significant_Edge is the current highest-precedence edge on + -- the path of the potential cycle. + -- + -- * Invocation_Edge_Count is the number of invocation edges on the + -- path of the potential cycle. + -- + -- * Cycle_Path_Stack is the path of the potential cycle. + -- + -- * Visited_Set is the set of vertices that have been visited during + -- the current depth-first search. + -- + -- * Visited_Stack maintains the vertices of Visited_Set in a stack + -- for later unvisiting. + -- + -- * Cycle_Count is the number of cycles discovered so far. + -- + -- * Cycle_Limit is the upper bound of the number of cycles to be + -- discovered. + -- + -- * Elaborate_All_Active should be set when the component currently + -- being examined for cycles contains an Elaborate_All edge. + -- + -- * Indent in the desired indentation level for tracing. + + procedure Find_Cycles_From_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + End_Vertices : LGV_Sets.Membership_Set; + Deleted_Vertices : LGV_Sets.Membership_Set; + Most_Significant_Edge : Library_Graph_Edge_Id; + Invocation_Edge_Count : Natural; + Cycle_Path_Stack : LGE_Lists.Doubly_Linked_List; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List; + Cycle_Count : in out Natural; + Cycle_Limit : Natural; + Elaborate_All_Active : Boolean; + Is_Start_Vertex : Boolean; + Has_Cycle : out Boolean; + Indent : Indentation_Level); + pragma Inline (Find_Cycles_From_Vertex); + -- Part of Tarjan's enumeration of the elementary circuits of a directed + -- graph algorithm. Find all cycles from vertex Vertex of library graph + -- G. If at least one cycle exists, set Has_Cycle to True. The remaining + -- parameters are as follows: + -- + -- * End_Vertices is the set of vertices that terminate a potential + -- cycle. + -- + -- * Deleted_Vertices is the set of vertices that have been expanded + -- during previous depth-first searches and should not be visited + -- for the rest of the algorithm. + -- + -- * Most_Significant_Edge is the current highest-precedence edge on + -- the path of the potential cycle. + -- + -- * Invocation_Edge_Count is the number of invocation edges on the + -- path of the potential cycle. + -- + -- * Cycle_Path_Stack is the path of the potential cycle. + -- + -- * Visited_Set is the set of vertices that have been visited during + -- the current depth-first search. + -- + -- * Visited_Stack maintains the vertices of Visited_Set in a stack + -- for later unvisiting. + -- + -- * Cycle_Count is the number of cycles discovered so far. + -- + -- * Cycle_Limit is the upper bound of the number of cycles to be + -- discovered. + -- + -- * Elaborate_All_Active should be set when the component currently + -- being examined for cycles contains an Elaborate_All edge. + -- + -- * Indent in the desired indentation level for tracing. + + procedure Find_Cycles_In_Component + (G : Library_Graph; + Comp : Component_Id; + Cycle_Count : in out Natural; + Cycle_Limit : Natural); + pragma Inline (Find_Cycles_In_Component); + -- Part of Tarjan's enumeration of the elementary circuits of a directed + -- graph algorithm. Find all cycles in component Comp of library graph + -- G. The remaining parameters are as follows: + -- + -- * Cycle_Count is the number of cycles discovered so far. + -- + -- * Cycle_Limit is the upper bound of the number of cycles to be + -- discovered. + + function Find_First_Lower_Precedence_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Library_Graph_Cycle_Id; + pragma Inline (Find_First_Lower_Precedence_Cycle); + -- Inspect the list of cycles of library graph G and return the first + -- cycle whose precedence is lower than that of cycle Cycle. If there + -- is no such cycle, return No_Library_Graph_Cycle. procedure Free is new Ada.Unchecked_Deallocation @@ -1005,27 +1295,56 @@ package body Bindo.Graphs is pragma Inline (Get_Component_Attributes); -- Obtain the attributes of component Comp of library graph G + function Get_LGC_Attributes + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Library_Graph_Cycle_Attributes; + pragma Inline (Get_LGC_Attributes); + -- Obtain the attributes of cycle Cycle of library graph G + function Get_LGE_Attributes - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Edge_Attributes; pragma Inline (Get_LGE_Attributes); - -- Obtain the attributes of edge LGE_Id of library graph G + -- Obtain the attributes of edge Edge of library graph G function Get_LGV_Attributes (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Attributes; pragma Inline (Get_LGV_Attributes); - -- Obtain the attributes of vertex LGE_Id of library graph G + -- Obtain the attributes of vertex Edge of library graph G function Has_Elaborate_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Has_Elaborate_Body); - -- Determine whether vertex LGV_Id of library graph G is subject to + -- Determine whether vertex Vertex of library graph G is subject to -- pragma Elaborate_Body. + function Has_Elaborate_All_Edge + (G : Library_Graph; + Comp : Component_Id) return Boolean; + pragma Inline (Has_Elaborate_All_Edge); + -- Determine whether component Comp of library graph G contains an + -- Elaborate_All edge that links two vertices in the same component. + + function Has_Elaborate_All_Edge + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Has_Elaborate_All_Edge); + -- Determine whether vertex Vertex of library graph G contains an + -- Elaborate_All edge to a successor where both the vertex and the + -- successor reside in the same component. + + function Highest_Precedence_Edge + (G : Library_Graph; + Left : Library_Graph_Edge_Id; + Right : Library_Graph_Edge_Id) return Library_Graph_Edge_Id; + pragma Inline (Highest_Precedence_Edge); + -- Return the edge with highest precedence among edges Left and Right of + -- library graph G. + procedure Increment_Library_Graph_Edge_Count (G : Library_Graph; Kind : Library_Graph_Edge_Kind); @@ -1034,37 +1353,154 @@ package body Bindo.Graphs is procedure Increment_Pending_Predecessors (G : Library_Graph; - Comp : Component_Id); + Comp : Component_Id; + Edge : Library_Graph_Edge_Id); pragma Inline (Increment_Pending_Predecessors); - -- Increment the number of pending precedessors component Comp of - -- library graph G must wait on before it can be elaborated by one. + -- Increment the number of pending predecessors component Comp which was + -- reached via edge Edge of library graph G must wait on before it can + -- be elaborated by one. procedure Increment_Pending_Predecessors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id); + Vertex : Library_Graph_Vertex_Id; + Edge : Library_Graph_Edge_Id); pragma Inline (Increment_Pending_Predecessors); - -- Increment the number of pending precedessors vertex LGV_Id of library - -- graph G must wait on before it can be elaborated by one. + -- Increment the number of pending predecessors vertex Vertex which was + -- reached via edge Edge of library graph G must wait on before it can + -- be elaborated by one. procedure Initialize_Components (G : Library_Graph); pragma Inline (Initialize_Components); -- Initialize on the initial call or re-initialize on subsequent calls -- all components of library graph G. - function Is_Elaborable_Vertex - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Predecessors : Natural) return Boolean; - pragma Inline (Is_Elaborable_Vertex); - -- Determine whether vertex LGV_Id of library graph G can be elaborated - -- given that it meets number of predecessors Predecessors. + function Is_Cycle_Initiating_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cycle_Initiating_Edge); + -- Determine whether edge Edge of library graph G starts a cycle + + function Is_Cyclic_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cyclic_Edge); + -- Determine whether edge Edge of library graph G participates in a + -- cycle. + + function Is_Cyclic_Elaborate_All_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cyclic_Elaborate_All_Edge); + -- Determine whether edge Edge of library graph G participates in a + -- cycle and has a predecessor that is subject to pragma Elaborate_All. + + function Is_Cyclic_Elaborate_Body_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cyclic_Elaborate_Body_Edge); + -- Determine whether edge Edge of library graph G participates in a + -- cycle and has a successor that is either a spec subject to pragma + -- Elaborate_Body, or a body that completes such a spec. + + function Is_Cyclic_Elaborate_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cyclic_Elaborate_Edge); + -- Determine whether edge Edge of library graph G participates in a + -- cycle and has a predecessor that is subject to pragma Elaborate. + + function Is_Cyclic_Forced_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cyclic_Forced_Edge); + -- Determine whether edge Edge of library graph G participates in a + -- cycle and came from the forced-elaboration-order file. - function Is_Existing_Predecessor_Successor_Relation + function Is_Cyclic_Invocation_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cyclic_Invocation_Edge); + -- Determine whether edge Edge of library graph G participates in a + -- cycle and came from the traversal of the invocation graph. + + function Is_Cyclic_With_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Cyclic_With_Edge); + -- Determine whether edge Edge of library graph G participates in a + -- cycle and is the result of a with dependency between its successor + -- and predecessor. + + function Is_Recorded_Edge (G : Library_Graph; Rel : Predecessor_Successor_Relation) return Boolean; - pragma Inline (Is_Existing_Predecessor_Successor_Relation); + pragma Inline (Is_Recorded_Edge); -- Determine whether a predecessor vertex and a successor vertex - -- desctibed by relation Rel are already related in library graph G. + -- described by relation Rel are already linked in library graph G. + + function Is_Static_Successor_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Static_Successor_Edge); + -- Determine whether the successor of invocation edge Edge represents a + -- unit that was compiled with the static model. + + function Is_Vertex_With_Elaborate_Body + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Vertex_With_Elaborate_Body); + -- Determine whether vertex Vertex of library graph G denotes a spec + -- subject to pragma Elaborate_Body or the completing body of such a + -- spec. + + function Links_Vertices_In_Same_Component + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Links_Vertices_In_Same_Component); + -- Determine whether edge Edge of library graph G links a predecessor + -- and successor that reside in the same component. + + function Maximum_Invocation_Edge_Count + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + Count : Natural) return Natural; + pragma Inline (Maximum_Invocation_Edge_Count); + -- Determine whether edge Edge of library graph G is an invocation edge, + -- and if it is return Count + 1, otherwise return Count. + + procedure Normalize_Cycle_Path + (Cycle_Path : LGE_Lists.Doubly_Linked_List; + Most_Significant_Edge : Library_Graph_Edge_Id); + pragma Inline (Normalize_Cycle_Path); + -- Normalize cycle path Path by rotating it until its starting edge is + -- Sig_Edge. + + procedure Order_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id); + pragma Inline (Order_Cycle); + -- Insert cycle Cycle in library graph G and sort it based on its + -- precedence relative to all recorded cycles. + + function Path + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return LGE_Lists.Doubly_Linked_List; + pragma Inline (Path); + -- Obtain the path of edges which comprises cycle Cycle of library + -- graph G. + + procedure Record_Cycle + (G : Library_Graph; + Most_Significant_Edge : Library_Graph_Edge_Id; + Invocation_Edge_Count : Natural; + Cycle_Path : LGE_Lists.Doubly_Linked_List; + Indent : Indentation_Level); + pragma Inline (Record_Cycle); + -- Normalize a cycle described by its path Cycle_Path and add it to + -- library graph G. Most_Significant_Edge denotes the edge with the + -- highest significance along the cycle path. Invocation_Edge_Count + -- is the number of invocation edges along the cycle path. Indent is + -- the desired indentation level for tracing. procedure Set_Component_Attributes (G : Library_Graph; @@ -1080,27 +1516,85 @@ package body Bindo.Graphs is pragma Inline (Set_Corresponding_Vertex); -- Associate vertex Val of library graph G with unit U_Id - procedure Set_Is_Existing_Predecessor_Successor_Relation + procedure Set_Is_Recorded_Edge (G : Library_Graph; Rel : Predecessor_Successor_Relation; Val : Boolean := True); - pragma Inline (Set_Is_Existing_Predecessor_Successor_Relation); - -- Mark a a predecessor vertex and a successor vertex desctibed by - -- relation Rel as already related depending on value Val. + pragma Inline (Set_Is_Recorded_Edge); + -- Mark a predecessor vertex and a successor vertex described by + -- relation Rel as already linked depending on value Val. + + procedure Set_LGC_Attributes + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Val : Library_Graph_Cycle_Attributes); + pragma Inline (Set_LGC_Attributes); + -- Set the attributes of cycle Cycle of library graph G to value Val procedure Set_LGE_Attributes - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id; - Val : Library_Graph_Edge_Attributes); + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + Val : Library_Graph_Edge_Attributes); pragma Inline (Set_LGE_Attributes); - -- Set the attributes of edge LGE_Id of library graph G to value Val + -- Set the attributes of edge Edge of library graph G to value Val procedure Set_LGV_Attributes (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Val : Library_Graph_Vertex_Attributes); pragma Inline (Set_LGV_Attributes); - -- Set the attributes of vertex LGV_Id of library graph G to value Val + -- Set the attributes of vertex Vertex of library graph G to value Val + + procedure Trace_Component + (G : Library_Graph; + Comp : Component_Id; + Indent : Indentation_Level); + pragma Inline (Trace_Component); + -- Write the contents of component Comp of library graph G to standard + -- output. Indent is the desired indentation level for tracing. + + procedure Trace_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Indent : Indentation_Level); + pragma Inline (Trace_Cycle); + -- Write the contents of cycle Cycle of library graph G to standard + -- output. Indent is the desired indentation level for tracing. + + procedure Trace_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + Indent : Indentation_Level); + pragma Inline (Trace_Edge); + -- Write the contents of edge Edge of library graph G to standard + -- output. Indent is the desired indentation level for tracing. + + procedure Trace_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Indent : Indentation_Level); + pragma Inline (Trace_Vertex); + -- Write the contents of vertex Vertex of library graph G to standard + -- output. Indent is the desired indentation level for tracing. + + procedure Unvisit + (Vertex : Library_Graph_Vertex_Id; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List); + pragma Inline (Unvisit); + -- Part of Tarjan's enumeration of the elementary circuits of a directed + -- graph algorithm. Unwind the Visited_Stack by removing the top vertex + -- from set Visited_Set until vertex Vertex is reached, inclusive. + + procedure Update_Pending_Predecessors + (Strong_Predecessors : in out Natural; + Weak_Predecessors : in out Natural; + Update_Weak : Boolean; + Value : Integer); + pragma Inline (Update_Pending_Predecessors); + -- Update the number of pending strong or weak predecessors denoted by + -- Strong_Predecessors and Weak_Predecessors respectively depending on + -- flag Update_Weak by adding value Value. procedure Update_Pending_Predecessors_Of_Components (G : Library_Graph); pragma Inline (Update_Pending_Predecessors_Of_Components); @@ -1108,31 +1602,65 @@ package body Bindo.Graphs is -- graph G must wait on before they can be elaborated. procedure Update_Pending_Predecessors_Of_Components - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id); + (G : Library_Graph; + Edge : Library_Graph_Edge_Id); pragma Inline (Update_Pending_Predecessors_Of_Components); -- Update the number of pending predecessors the component of edge -- LGE_Is's successor vertex of library graph G must wait on before -- it can be elaborated. + function Vertex_Precedence + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Compared_To : Library_Graph_Vertex_Id) return Precedence_Kind; + pragma Inline (Vertex_Precedence); + -- Determine the precedence of vertex Vertex of library graph G compared + -- to vertex Compared_To. + + procedure Visit + (Vertex : Library_Graph_Vertex_Id; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List); + pragma Inline (Visit); + -- Part of Tarjan's enumeration of the elementary circuits of a directed + -- graph algorithm. Push vertex Vertex on the Visited_Stack and add it + -- to set Visited_Set. + + -------------------- + -- Activates_Task -- + -------------------- + + function Activates_Task + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Kind (G, Edge) = Invocation_Edge + and then Get_LGE_Attributes (G, Edge).Activates_Task; + end Activates_Task; + ------------------------------- -- Add_Body_Before_Spec_Edge -- ------------------------------- procedure Add_Body_Before_Spec_Edge (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Edges : EL.Doubly_Linked_List) + Vertex : Library_Graph_Vertex_Id; + Edges : LGE_Lists.Doubly_Linked_List) is - LGE_Id : Library_Graph_Edge_Id; + Edge : Library_Graph_Edge_Id; begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - pragma Assert (EL.Present (Edges)); + pragma Assert (Present (Vertex)); + pragma Assert (LGE_Lists.Present (Edges)); -- A vertex requires a special Body_Before_Spec edge to its - -- Corresponging_Item when it either denotes a + -- Corresponding_Item when it either denotes a -- -- * Body that completes a previous spec -- @@ -1150,31 +1678,33 @@ package body Bindo.Graphs is -- Assume that that no Body_Before_Spec is necessary - LGE_Id := No_Library_Graph_Edge; + Edge := No_Library_Graph_Edge; -- A body that completes a previous spec - if Is_Body_With_Spec (G, LGV_Id) then - LGE_Id := + if Is_Body_With_Spec (G, Vertex) then + Edge := Add_Edge_With_Return - (G => G, - Pred => LGV_Id, -- body - Succ => Corresponding_Item (G, LGV_Id), -- spec - Kind => Body_Before_Spec_Edge); + (G => G, + Pred => Vertex, + Succ => Corresponding_Item (G, Vertex), + Kind => Body_Before_Spec_Edge, + Activates_Task => False); -- A spec with a completing body - elsif Is_Spec_With_Body (G, LGV_Id) then - LGE_Id := + elsif Is_Spec_With_Body (G, Vertex) then + Edge := Add_Edge_With_Return - (G => G, - Pred => Corresponding_Item (G, LGV_Id), -- body - Succ => LGV_Id, -- spec - Kind => Body_Before_Spec_Edge); + (G => G, + Pred => Corresponding_Item (G, Vertex), + Succ => Vertex, + Kind => Body_Before_Spec_Edge, + Activates_Task => False); end if; - if Present (LGE_Id) then - EL.Append (Edges, LGE_Id); + if Present (Edge) then + LGE_Lists.Append (Edges, Edge); end if; end Add_Body_Before_Spec_Edge; @@ -1184,24 +1714,23 @@ package body Bindo.Graphs is procedure Add_Body_Before_Spec_Edges (G : Library_Graph; - Edges : EL.Doubly_Linked_List) + Edges : LGE_Lists.Doubly_Linked_List) is - Iter : Elaborable_Units_Iterator; - LGV_Id : Library_Graph_Vertex_Id; - U_Id : Unit_Id; + Iter : Elaborable_Units_Iterator; + U_Id : Unit_Id; begin pragma Assert (Present (G)); - pragma Assert (EL.Present (Edges)); + pragma Assert (LGE_Lists.Present (Edges)); Iter := Iterate_Elaborable_Units; while Has_Next (Iter) loop Next (Iter, U_Id); - LGV_Id := Corresponding_Vertex (G, U_Id); - pragma Assert (Present (LGV_Id)); - - Add_Body_Before_Spec_Edge (G, LGV_Id, Edges); + Add_Body_Before_Spec_Edge + (G => G, + Vertex => Corresponding_Vertex (G, U_Id), + Edges => Edges); end loop; end Add_Body_Before_Spec_Edges; @@ -1210,26 +1739,29 @@ package body Bindo.Graphs is -------------- procedure Add_Edge - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - Succ : Library_Graph_Vertex_Id; - Kind : Library_Graph_Edge_Kind) + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind; + Activates_Task : Boolean) is - LGE_Id : Library_Graph_Edge_Id; - pragma Unreferenced (LGE_Id); + Edge : Library_Graph_Edge_Id; + pragma Unreferenced (Edge); begin pragma Assert (Present (G)); pragma Assert (Present (Pred)); pragma Assert (Present (Succ)); pragma Assert (Kind /= No_Edge); + pragma Assert (not Activates_Task or else Kind = Invocation_Edge); - LGE_Id := + Edge := Add_Edge_With_Return - (G => G, - Pred => Pred, - Succ => Succ, - Kind => Kind); + (G => G, + Pred => Pred, + Succ => Succ, + Kind => Kind, + Activates_Task => Activates_Task); end Add_Edge; -------------------------- @@ -1237,10 +1769,11 @@ package body Bindo.Graphs is -------------------------- function Add_Edge_With_Return - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - Succ : Library_Graph_Vertex_Id; - Kind : Library_Graph_Edge_Kind) return Library_Graph_Edge_Id + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind; + Activates_Task : Boolean) return Library_Graph_Edge_Id is pragma Assert (Present (G)); pragma Assert (Present (Pred)); @@ -1251,17 +1784,17 @@ package body Bindo.Graphs is (Predecessor => Pred, Successor => Succ); - LGE_Id : Library_Graph_Edge_Id; + Edge : Library_Graph_Edge_Id; begin -- Nothing to do when the predecessor and successor are already -- related by an edge. - if Is_Existing_Predecessor_Successor_Relation (G, Rel) then + if Is_Recorded_Edge (G, Rel) then return No_Library_Graph_Edge; end if; - LGE_Id := Sequence_Next_LGE_Id; + Edge := Sequence_Next_Edge; -- Add the edge to the underlying graph. Note that the predecessor -- is the source of the edge because it will later need to notify @@ -1269,33 +1802,38 @@ package body Bindo.Graphs is DG.Add_Edge (G => G.Graph, - E => LGE_Id, + E => Edge, Source => Pred, Destination => Succ); -- Construct and save the attributes of the edge Set_LGE_Attributes - (G => G, - LGE_Id => LGE_Id, - Val => (Kind => Kind)); + (G => G, + Edge => Edge, + Val => + (Activates_Task => Activates_Task, + Kind => Kind)); -- Mark the predecessor and successor as related by the new edge. -- This prevents all further attempts to link the same predecessor -- and successor. - Set_Is_Existing_Predecessor_Successor_Relation (G, Rel); + Set_Is_Recorded_Edge (G, Rel); -- Update the number of pending predecessors the successor must wait -- on before it is elaborated. - Increment_Pending_Predecessors (G, Succ); + Increment_Pending_Predecessors + (G => G, + Vertex => Succ, + Edge => Edge); -- Update the edge statistics Increment_Library_Graph_Edge_Count (G, Kind); - return LGE_Id; + return Edge; end Add_Edge_With_Return; ---------------- @@ -1306,7 +1844,7 @@ package body Bindo.Graphs is (G : Library_Graph; U_Id : Unit_Id) is - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; begin pragma Assert (Present (G)); @@ -1318,55 +1856,217 @@ package body Bindo.Graphs is return; end if; - LGV_Id := Sequence_Next_LGV_Id; + Vertex := Sequence_Next_Vertex; -- Add the vertex to the underlying graph - DG.Add_Vertex (G.Graph, LGV_Id); + DG.Add_Vertex (G.Graph, Vertex); -- Construct and save the attributes of the vertex Set_LGV_Attributes (G => G, - LGV_Id => LGV_Id, - Val => (Corresponding_Item => No_Library_Graph_Vertex, - In_Elaboration_Order => False, - Pending_Predecessors => 0, - Unit => U_Id)); + Vertex => Vertex, + Val => + (Corresponding_Item => No_Library_Graph_Vertex, + In_Elaboration_Order => False, + Pending_Strong_Predecessors => 0, + Pending_Weak_Predecessors => 0, + Unit => U_Id)); -- Associate the unit with its corresponding vertex - Set_Corresponding_Vertex (G, U_Id, LGV_Id); + Set_Corresponding_Vertex (G, U_Id, Vertex); end Add_Vertex; + --------------------------------- + -- At_Least_One_Edge_Satisfies -- + --------------------------------- + + function At_Least_One_Edge_Satisfies + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Predicate : LGE_Predicate_Ptr) return Boolean + is + Edge : Library_Graph_Edge_Id; + Iter : Edges_Of_Cycle_Iterator; + Satisfied : Boolean; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + pragma Assert (Predicate /= null); + + -- Assume that the predicate cannot be satisfied + + Satisfied := False; + + -- IMPORTANT: + -- + -- * The iteration must run to completion in order to unlock the + -- edges of the cycle. + + Iter := Iterate_Edges_Of_Cycle (G, Cycle); + while Has_Next (Iter) loop + Next (Iter, Edge); + + Satisfied := Satisfied or else Predicate.all (G, Edge); + end loop; + + return Satisfied; + end At_Least_One_Edge_Satisfies; + + -------------------------- + -- Complementary_Vertex -- + -------------------------- + + function Complementary_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Force_Complement : Boolean) return Library_Graph_Vertex_Id + is + Complement : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + -- Assume that there is no complementary vertex + + Complement := No_Library_Graph_Vertex; + + -- The caller requests the complement explicitly + + if Force_Complement then + Complement := Corresponding_Item (G, Vertex); + + -- The vertex is a completing body of a spec subject to pragma + -- Elaborate_Body. The complementary vertex is the spec. + + elsif Is_Body_Of_Spec_With_Elaborate_Body (G, Vertex) then + Complement := Proper_Spec (G, Vertex); + + -- The vertex is a spec subject to pragma Elaborate_Body. The + -- complementary vertex is the body. + + elsif Is_Spec_With_Elaborate_Body (G, Vertex) then + Complement := Proper_Body (G, Vertex); + end if; + + return Complement; + end Complementary_Vertex; + --------------- -- Component -- --------------- function Component (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Component_Id + Vertex : Library_Graph_Vertex_Id) return Component_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - return DG.Component (G.Graph, LGV_Id); + return DG.Component (G.Graph, Vertex); end Component; + --------------------------------- + -- Contains_Elaborate_All_Edge -- + --------------------------------- + + function Contains_Elaborate_All_Edge + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return + At_Least_One_Edge_Satisfies + (G => G, + Cycle => Cycle, + Predicate => Is_Elaborate_All_Edge'Access); + end Contains_Elaborate_All_Edge; + + ------------------------------------ + -- Contains_Static_Successor_Edge -- + ------------------------------------ + + function Contains_Static_Successor_Edge + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return + At_Least_One_Edge_Satisfies + (G => G, + Cycle => Cycle, + Predicate => Is_Static_Successor_Edge'Access); + end Contains_Static_Successor_Edge; + + ------------------------------ + -- Contains_Task_Activation -- + ------------------------------ + + function Contains_Task_Activation + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return + At_Least_One_Edge_Satisfies + (G => G, + Cycle => Cycle, + Predicate => Activates_Task'Access); + end Contains_Task_Activation; + + --------------------- + -- Copy_Cycle_Path -- + --------------------- + + function Copy_Cycle_Path + (Cycle_Path : LGE_Lists.Doubly_Linked_List) + return LGE_Lists.Doubly_Linked_List + is + Edge : Library_Graph_Edge_Id; + Iter : LGE_Lists.Iterator; + Path : LGE_Lists.Doubly_Linked_List; + + begin + pragma Assert (LGE_Lists.Present (Cycle_Path)); + + Path := LGE_Lists.Create; + Iter := LGE_Lists.Iterate (Cycle_Path); + while LGE_Lists.Has_Next (Iter) loop + LGE_Lists.Next (Iter, Edge); + + LGE_Lists.Append (Path, Edge); + end loop; + + return Path; + end Copy_Cycle_Path; + ------------------------ -- Corresponding_Item -- ------------------------ function Corresponding_Item (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - return Get_LGV_Attributes (G, LGV_Id).Corresponding_Item; + return Get_LGV_Attributes (G, Vertex).Corresponding_Item; end Corresponding_Item; -------------------------- @@ -1381,7 +2081,7 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (U_Id)); - return UV.Get (G.Unit_To_Vertex, U_Id); + return Unit_Tables.Get (G.Unit_To_Vertex, U_Id); end Corresponding_Vertex; ------------ @@ -1395,19 +2095,264 @@ package body Bindo.Graphs is G : constant Library_Graph := new Library_Graph_Attributes; begin - G.Component_Attributes := CA.Create (Initial_Vertices); - G.Edge_Attributes := EA.Create (Initial_Edges); + G.Component_Attributes := Component_Tables.Create (Initial_Vertices); + G.Cycle_Attributes := LGC_Tables.Create (Initial_Vertices); + G.Cycles := LGC_Lists.Create; + G.Edge_Attributes := LGE_Tables.Create (Initial_Edges); G.Graph := DG.Create (Initial_Vertices => Initial_Vertices, Initial_Edges => Initial_Edges); - G.Relations := PS.Create (Initial_Edges); - G.Unit_To_Vertex := UV.Create (Initial_Vertices); - G.Vertex_Attributes := VA.Create (Initial_Vertices); + G.Recorded_Edges := RE_Sets.Create (Initial_Edges); + G.Unit_To_Vertex := Unit_Tables.Create (Initial_Vertices); + G.Vertex_Attributes := LGV_Tables.Create (Initial_Vertices); return G; end Create; + ------------------------ + -- Cycle_End_Vertices -- + ------------------------ + + function Cycle_End_Vertices + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Elaborate_All_Active : Boolean) return LGV_Sets.Membership_Set + is + Complement : Library_Graph_Vertex_Id; + End_Vertices : LGV_Sets.Membership_Set := LGV_Sets.Nil; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + End_Vertices := LGV_Sets.Create (2); + + -- The input vertex always terminates a cycle path + + LGV_Sets.Insert (End_Vertices, Vertex); + + -- Add the complementary vertex to the set of cycle terminating + -- vertices when either Elaborate_All is in effect, or the input + -- vertex is part of an Elaborat_Body pair. + + if Elaborate_All_Active + or else Is_Vertex_With_Elaborate_Body (G, Vertex) + then + Complement := + Complementary_Vertex + (G => G, + Vertex => Vertex, + Force_Complement => Elaborate_All_Active); + + if Present (Complement) then + LGV_Sets.Insert (End_Vertices, Complement); + end if; + end if; + + return End_Vertices; + end Cycle_End_Vertices; + + ------------------- + -- Cycle_Kind_Of -- + ------------------- + + function Cycle_Kind_Of + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Cycle_Kind + is + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + begin + if Is_Cyclic_Elaborate_All_Edge (G, Edge) then + return Elaborate_All_Cycle; + + elsif Is_Cyclic_Elaborate_Body_Edge (G, Edge) then + return Elaborate_Body_Cycle; + + elsif Is_Cyclic_Elaborate_Edge (G, Edge) then + return Elaborate_Cycle; + + elsif Is_Cyclic_Forced_Edge (G, Edge) then + return Forced_Cycle; + + elsif Is_Cyclic_Invocation_Edge (G, Edge) then + return Invocation_Cycle; + + else + return No_Cycle_Kind; + end if; + end Cycle_Kind_Of; + + --------------------------- + -- Cycle_Kind_Precedence -- + --------------------------- + + function Cycle_Kind_Precedence + (Kind : Library_Graph_Cycle_Kind; + Compared_To : Library_Graph_Cycle_Kind) return Precedence_Kind + is + Comp_Pos : constant Integer := + Library_Graph_Cycle_Kind'Pos (Compared_To); + Kind_Pos : constant Integer := Library_Graph_Cycle_Kind'Pos (Kind); + + begin + -- A lower ordinal indicates a higher precedence + + if Kind_Pos < Comp_Pos then + return Higher_Precedence; + + elsif Kind_Pos > Comp_Pos then + return Lower_Precedence; + + else + return Equal_Precedence; + end if; + end Cycle_Kind_Precedence; + + --------------------------- + -- Cycle_Path_Precedence -- + --------------------------- + + function Cycle_Path_Precedence + (G : Library_Graph; + Path : LGE_Lists.Doubly_Linked_List; + Compared_To : LGE_Lists.Doubly_Linked_List) return Precedence_Kind + is + procedure Next_Available + (Iter : in out LGE_Lists.Iterator; + Edge : out Library_Graph_Edge_Id); + pragma Inline (Next_Available); + -- Obtain the next edge available through iterator Iter, or return + -- No_Library_Graph_Edge if the iterator has been exhausted. + + -------------------- + -- Next_Available -- + -------------------- + + procedure Next_Available + (Iter : in out LGE_Lists.Iterator; + Edge : out Library_Graph_Edge_Id) + is + begin + -- Assume that the iterator has been exhausted + + Edge := No_Library_Graph_Edge; + + if LGE_Lists.Has_Next (Iter) then + LGE_Lists.Next (Iter, Edge); + end if; + end Next_Available; + + -- Local variables + + Comp_Edge : Library_Graph_Edge_Id; + Comp_Iter : LGE_Lists.Iterator; + Path_Edge : Library_Graph_Edge_Id; + Path_Iter : LGE_Lists.Iterator; + Prec : Precedence_Kind; + + -- Start of processing for Cycle_Path_Precedence + + begin + pragma Assert (Present (G)); + pragma Assert (LGE_Lists.Present (Path)); + pragma Assert (LGE_Lists.Present (Compared_To)); + + -- Assume that the paths have equal precedence + + Prec := Equal_Precedence; + + Comp_Iter := LGE_Lists.Iterate (Compared_To); + Path_Iter := LGE_Lists.Iterate (Path); + + Next_Available (Comp_Iter, Comp_Edge); + Next_Available (Path_Iter, Path_Edge); + + -- IMPORTANT: + -- + -- * The iteration must run to completion in order to unlock the + -- edges of both paths. + + while Present (Comp_Edge) or else Present (Path_Edge) loop + if Prec = Equal_Precedence + and then Present (Comp_Edge) + and then Present (Path_Edge) + then + Prec := + Edge_Precedence + (G => G, + Edge => Path_Edge, + Compared_To => Comp_Edge); + end if; + + Next_Available (Comp_Iter, Comp_Edge); + Next_Available (Path_Iter, Path_Edge); + end loop; + + return Prec; + end Cycle_Path_Precedence; + + ---------------------- + -- Cycle_Precedence -- + ---------------------- + + function Cycle_Precedence + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Compared_To : Library_Graph_Cycle_Id) return Precedence_Kind + is + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + pragma Assert (Present (Compared_To)); + + Comp_Invs : constant Natural := + Invocation_Edge_Count (G, Compared_To); + Comp_Len : constant Natural := Length (G, Compared_To); + Cycle_Invs : constant Natural := Invocation_Edge_Count (G, Cycle); + Cycle_Len : constant Natural := Length (G, Cycle); + Kind_Prec : constant Precedence_Kind := + Cycle_Kind_Precedence + (Kind => Kind (G, Cycle), + Compared_To => Kind (G, Compared_To)); + + begin + -- Prefer a cycle with higher precedence based on its kind + + if Kind_Prec = Higher_Precedence + or else + Kind_Prec = Lower_Precedence + then + return Kind_Prec; + + -- Prefer a shorter cycle + + elsif Cycle_Len < Comp_Len then + return Higher_Precedence; + + elsif Cycle_Len > Comp_Len then + return Lower_Precedence; + + -- Prefer a cycle wih fewer invocation edges + + elsif Cycle_Invs < Comp_Invs then + return Higher_Precedence; + + elsif Cycle_Invs > Comp_Invs then + return Lower_Precedence; + + -- Prefer a cycle with a higher path precedence + + else + return + Cycle_Path_Precedence + (G => G, + Path => Path (G, Cycle), + Compared_To => Path (G, Compared_To)); + end if; + end Cycle_Precedence; + ---------------------------------------- -- Decrement_Library_Graph_Edge_Count -- ---------------------------------------- @@ -1430,7 +2375,8 @@ package body Bindo.Graphs is procedure Decrement_Pending_Predecessors (G : Library_Graph; - Comp : Component_Id) + Comp : Component_Id; + Edge : Library_Graph_Edge_Id) is Attrs : Component_Attributes; @@ -1439,7 +2385,13 @@ package body Bindo.Graphs is pragma Assert (Present (Comp)); Attrs := Get_Component_Attributes (G, Comp); - Attrs.Pending_Predecessors := Attrs.Pending_Predecessors - 1; + + Update_Pending_Predecessors + (Strong_Predecessors => Attrs.Pending_Strong_Predecessors, + Weak_Predecessors => Attrs.Pending_Weak_Predecessors, + Update_Weak => Is_Invocation_Edge (G, Edge), + Value => -1); + Set_Component_Attributes (G, Comp, Attrs); end Decrement_Pending_Predecessors; @@ -1449,17 +2401,24 @@ package body Bindo.Graphs is procedure Decrement_Pending_Predecessors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id; + Edge : Library_Graph_Edge_Id) is Attrs : Library_Graph_Vertex_Attributes; begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); + + Attrs := Get_LGV_Attributes (G, Vertex); - Attrs := Get_LGV_Attributes (G, LGV_Id); - Attrs.Pending_Predecessors := Attrs.Pending_Predecessors - 1; - Set_LGV_Attributes (G, LGV_Id, Attrs); + Update_Pending_Predecessors + (Strong_Predecessors => Attrs.Pending_Strong_Predecessors, + Weak_Predecessors => Attrs.Pending_Weak_Predecessors, + Update_Weak => Is_Invocation_Edge (G, Edge), + Value => -1); + + Set_LGV_Attributes (G, Vertex, Attrs); end Decrement_Pending_Predecessors; ----------------------------------- @@ -1468,22 +2427,21 @@ package body Bindo.Graphs is procedure Delete_Body_Before_Spec_Edges (G : Library_Graph; - Edges : EL.Doubly_Linked_List) + Edges : LGE_Lists.Doubly_Linked_List) is - Iter : EL.Iterator; - LGE_Id : Library_Graph_Edge_Id; + Edge : Library_Graph_Edge_Id; + Iter : LGE_Lists.Iterator; begin pragma Assert (Present (G)); - pragma Assert (EL.Present (Edges)); + pragma Assert (LGE_Lists.Present (Edges)); - Iter := EL.Iterate (Edges); - while EL.Has_Next (Iter) loop - EL.Next (Iter, LGE_Id); - pragma Assert (Present (LGE_Id)); - pragma Assert (Kind (G, LGE_Id) = Body_Before_Spec_Edge); + Iter := LGE_Lists.Iterate (Edges); + while LGE_Lists.Has_Next (Iter) loop + LGE_Lists.Next (Iter, Edge); + pragma Assert (Kind (G, Edge) = Body_Before_Spec_Edge); - Delete_Edge (G, LGE_Id); + Delete_Edge (G, Edge); end loop; end Delete_Body_Before_Spec_Edges; @@ -1492,44 +2450,43 @@ package body Bindo.Graphs is ----------------- procedure Delete_Edge - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) is pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); - - Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); - Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); - - pragma Assert (Present (Pred)); - pragma Assert (Present (Succ)); + pragma Assert (Present (Edge)); - Rel : constant Predecessor_Successor_Relation := - (Predecessor => Pred, - Successor => Succ); + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, Edge); + Succ : constant Library_Graph_Vertex_Id := Successor (G, Edge); + Rel : constant Predecessor_Successor_Relation := + (Predecessor => Pred, + Successor => Succ); begin -- Update the edge statistics - Decrement_Library_Graph_Edge_Count (G, Kind (G, LGE_Id)); + Decrement_Library_Graph_Edge_Count (G, Kind (G, Edge)); -- Update the number of pending predecessors the successor must wait -- on before it is elaborated. - Decrement_Pending_Predecessors (G, Succ); + Decrement_Pending_Predecessors + (G => G, + Vertex => Succ, + Edge => Edge); -- Delete the link between the predecessor and successor. This allows -- for further attempts to link the same predecessor and successor. - PS.Delete (G.Relations, Rel); + RE_Sets.Delete (G.Recorded_Edges, Rel); -- Delete the attributes of the edge - EA.Delete (G.Edge_Attributes, LGE_Id); + LGE_Tables.Delete (G.Edge_Attributes, Edge); -- Delete the edge from the underlying graph - DG.Delete_Edge (G.Graph, LGE_Id); + DG.Delete_Edge (G.Graph, Edge); end Delete_Edge; ------------- @@ -1540,12 +2497,14 @@ package body Bindo.Graphs is begin pragma Assert (Present (G)); - CA.Destroy (G.Component_Attributes); - EA.Destroy (G.Edge_Attributes); - DG.Destroy (G.Graph); - PS.Destroy (G.Relations); - UV.Destroy (G.Unit_To_Vertex); - VA.Destroy (G.Vertex_Attributes); + Component_Tables.Destroy (G.Component_Attributes); + LGC_Tables.Destroy (G.Cycle_Attributes); + LGC_Lists.Destroy (G.Cycles); + LGE_Tables.Destroy (G.Edge_Attributes); + DG.Destroy (G.Graph); + RE_Sets.Destroy (G.Recorded_Edges); + Unit_Tables.Destroy (G.Unit_To_Vertex); + LGV_Tables.Destroy (G.Vertex_Attributes); Free (G); end Destroy; @@ -1562,17 +2521,16 @@ package body Bindo.Graphs is null; end Destroy_Component_Attributes; - -------------------------------- - -- Destroy_Library_Graph_Edge -- - -------------------------------- + -------------------------------------------- + -- Destroy_Library_Graph_Cycle_Attributes -- + -------------------------------------------- - procedure Destroy_Library_Graph_Edge - (LGE_Id : in out Library_Graph_Edge_Id) + procedure Destroy_Library_Graph_Cycle_Attributes + (Attrs : in out Library_Graph_Cycle_Attributes) is - pragma Unreferenced (LGE_Id); begin - null; - end Destroy_Library_Graph_Edge; + LGE_Lists.Destroy (Attrs.Path); + end Destroy_Library_Graph_Cycle_Attributes; ------------------------------------------- -- Destroy_Library_Graph_Edge_Attributes -- @@ -1586,18 +2544,6 @@ package body Bindo.Graphs is null; end Destroy_Library_Graph_Edge_Attributes; - ---------------------------------- - -- Destroy_Library_Graph_Vertex -- - ---------------------------------- - - procedure Destroy_Library_Graph_Vertex - (LGV_Id : in out Library_Graph_Vertex_Id) - is - pragma Unreferenced (LGV_Id); - begin - null; - end Destroy_Library_Graph_Vertex; - --------------------------------------------- -- Destroy_Library_Graph_Vertex_Attributes -- --------------------------------------------- @@ -1611,15 +2557,88 @@ package body Bindo.Graphs is end Destroy_Library_Graph_Vertex_Attributes; --------------------- + -- Edge_Precedence -- + --------------------- + + function Edge_Precedence + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + Compared_To : Library_Graph_Edge_Id) return Precedence_Kind + is + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + pragma Assert (Present (Compared_To)); + + Comp_Succ : constant Library_Graph_Vertex_Id := + Successor (G, Compared_To); + Edge_Succ : constant Library_Graph_Vertex_Id := + Successor (G, Edge); + Kind_Prec : constant Precedence_Kind := + Cycle_Kind_Precedence + (Kind => Cycle_Kind_Of (G, Edge), + Compared_To => Cycle_Kind_Of (G, Compared_To)); + Succ_Prec : constant Precedence_Kind := + Vertex_Precedence + (G => G, + Vertex => Edge_Succ, + Compared_To => Comp_Succ); + + begin + -- Prefer an edge with a higher cycle kind precedence + + if Kind_Prec = Higher_Precedence + or else + Kind_Prec = Lower_Precedence + then + return Kind_Prec; + + -- Prefer an edge whose successor has a higher precedence + + elsif Comp_Succ /= Edge_Succ + and then (Succ_Prec = Higher_Precedence + or else + Succ_Prec = Lower_Precedence) + then + return Succ_Prec; + + -- Prefer an edge whose predecessor has a higher precedence + + else + return + Vertex_Precedence + (G => G, + Vertex => Predecessor (G, Edge), + Compared_To => Predecessor (G, Compared_To)); + end if; + end Edge_Precedence; + + --------------- + -- File_Name -- + --------------- + + function File_Name + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return File_Name_Type + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return File_Name (Unit (G, Vertex)); + end File_Name; + + --------------------- -- Find_Components -- --------------------- procedure Find_Components (G : Library_Graph) is - Edges : EL.Doubly_Linked_List; + Edges : LGE_Lists.Doubly_Linked_List; begin pragma Assert (Present (G)); + Start_Phase (Component_Discovery); + -- Initialize or reinitialize the components of the graph Initialize_Components (G); @@ -1629,7 +2648,7 @@ package body Bindo.Graphs is -- edges eliminates the need to create yet another graph, where both -- spec and body are collapsed into a single vertex. - Edges := EL.Create; + Edges := LGE_Lists.Create; Add_Body_Before_Spec_Edges (G, Edges); DG.Find_Components (G.Graph); @@ -1638,14 +2657,535 @@ package body Bindo.Graphs is -- successor spec because they cause unresolvable circularities. Delete_Body_Before_Spec_Edges (G, Edges); - EL.Destroy (Edges); + LGE_Lists.Destroy (Edges); -- Update the number of predecessors various components must wait on -- before they can be elaborated. Update_Pending_Predecessors_Of_Components (G); + End_Phase (Component_Discovery); end Find_Components; + ----------------- + -- Find_Cycles -- + ----------------- + + procedure Find_Cycles (G : Library_Graph) is + All_Cycle_Limit : constant Natural := 64; + -- The performance of Tarjan's algorithm may degrate to exponential + -- when pragma Elaborate_All is in effect, or some vertex is part of + -- an Elaborate_Body pair. In this case the algorithm discovers all + -- combinations of edges that close a circuit starting and ending on + -- some start vertex while going through different vertices. Use a + -- limit on the total number of cycles within a component to guard + -- against such degradation. + + Comp : Component_Id; + Cycle_Count : Natural; + Iter : Component_Iterator; + + begin + pragma Assert (Present (G)); + + Start_Phase (Cycle_Discovery); + + -- The cycles of graph G are discovered using Tarjan's enumeration + -- of the elementary circuits of a directed-graph algorithm. Do not + -- modify this code unless you intimately understand the algorithm. + -- + -- The logic of the algorithm is split among the following routines: + -- + -- Cycle_End_Vertices + -- Find_Cycles_From_Successor + -- Find_Cycles_From_Vertex + -- Find_Cycles_In_Component + -- Unvisit + -- Visit + -- + -- The original algorithm has been significantly modified in order to + -- + -- * Accommodate the semantics of Elaborate_All and Elaborate_Body. + -- + -- * Capture cycle paths as edges rather than vertices. + -- + -- * Take advantage of graph components. + + -- Assume that the graph does not contain a cycle + + Cycle_Count := 0; + + -- Run the modified version of the algorithm on each component of the + -- graph. + + Iter := Iterate_Components (G); + while Has_Next (Iter) loop + Next (Iter, Comp); + + Find_Cycles_In_Component + (G => G, + Comp => Comp, + Cycle_Count => Cycle_Count, + Cycle_Limit => All_Cycle_Limit); + end loop; + + End_Phase (Cycle_Discovery); + end Find_Cycles; + + -------------------------------- + -- Find_Cycles_From_Successor -- + -------------------------------- + + procedure Find_Cycles_From_Successor + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + End_Vertices : LGV_Sets.Membership_Set; + Deleted_Vertices : LGV_Sets.Membership_Set; + Most_Significant_Edge : Library_Graph_Edge_Id; + Invocation_Edge_Count : Natural; + Cycle_Path_Stack : LGE_Lists.Doubly_Linked_List; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List; + Cycle_Count : in out Natural; + Cycle_Limit : Natural; + Elaborate_All_Active : Boolean; + Has_Cycle : out Boolean; + Indent : Indentation_Level) + is + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + pragma Assert (LGV_Sets.Present (End_Vertices)); + pragma Assert (LGV_Sets.Present (Deleted_Vertices)); + pragma Assert (LGE_Lists.Present (Cycle_Path_Stack)); + pragma Assert (LGV_Sets.Present (Visited_Set)); + pragma Assert (LGV_Lists.Present (Visited_Stack)); + + Succ : constant Library_Graph_Vertex_Id := Successor (G, Edge); + Succ_Indent : constant Indentation_Level := + Indent + Nested_Indentation; + + begin + -- Assume that the successor reached via the edge does not result in + -- a cycle. + + Has_Cycle := False; + + -- Nothing to do when the edge connects two vertices residing in two + -- different components. + + if not Is_Cyclic_Edge (G, Edge) then + return; + end if; + + Trace_Edge (G, Edge, Indent); + + -- The modified version does not place vertices on the "point stack", + -- but instead collects the edges comprising the cycle. Prepare the + -- edge for backtracking. + + LGE_Lists.Prepend (Cycle_Path_Stack, Edge); + + Find_Cycles_From_Vertex + (G => G, + Vertex => Succ, + End_Vertices => End_Vertices, + Deleted_Vertices => Deleted_Vertices, + Most_Significant_Edge => Most_Significant_Edge, + Invocation_Edge_Count => Invocation_Edge_Count, + Cycle_Path_Stack => Cycle_Path_Stack, + Visited_Set => Visited_Set, + Visited_Stack => Visited_Stack, + Cycle_Count => Cycle_Count, + Cycle_Limit => Cycle_Limit, + Elaborate_All_Active => Elaborate_All_Active, + Is_Start_Vertex => False, + Has_Cycle => Has_Cycle, + Indent => Succ_Indent); + + -- The modified version does not place vertices on the "point stack", + -- but instead collects the edges comprising the cycle. Backtrack the + -- edge. + + LGE_Lists.Delete_First (Cycle_Path_Stack); + end Find_Cycles_From_Successor; + + ----------------------------- + -- Find_Cycles_From_Vertex -- + ----------------------------- + + procedure Find_Cycles_From_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + End_Vertices : LGV_Sets.Membership_Set; + Deleted_Vertices : LGV_Sets.Membership_Set; + Most_Significant_Edge : Library_Graph_Edge_Id; + Invocation_Edge_Count : Natural; + Cycle_Path_Stack : LGE_Lists.Doubly_Linked_List; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List; + Cycle_Count : in out Natural; + Cycle_Limit : Natural; + Elaborate_All_Active : Boolean; + Is_Start_Vertex : Boolean; + Has_Cycle : out Boolean; + Indent : Indentation_Level) + is + Edge_Indent : constant Indentation_Level := + Indent + Nested_Indentation; + + Complement : Library_Graph_Vertex_Id; + Edge : Library_Graph_Edge_Id; + Iter : Edges_To_Successors_Iterator; + + Complement_Has_Cycle : Boolean; + -- This flag is set when either Elaborate_All is in effect or the + -- current vertex is part of an Elaborate_Body pair, and visiting + -- the "complementary" vertex resulted in a cycle. + + Successor_Has_Cycle : Boolean; + -- This flag is set when visiting at least one successor of the + -- current vertex resulted in a cycle. + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + pragma Assert (LGV_Sets.Present (End_Vertices)); + pragma Assert (LGV_Sets.Present (Deleted_Vertices)); + pragma Assert (LGE_Lists.Present (Cycle_Path_Stack)); + pragma Assert (LGV_Sets.Present (Visited_Set)); + pragma Assert (LGV_Lists.Present (Visited_Stack)); + + -- Assume that the vertex does not close a circuit + + Has_Cycle := False; + + -- Nothing to do when the limit on the number of saved cycles has + -- been reached. This protects against a combinatorial explosion + -- in components with Elaborate_All cycles. + + if Cycle_Count >= Cycle_Limit then + return; + + -- The vertex closes the circuit, thus resulting in a cycle. Save + -- the cycle for later diagnostics. The initial invocation of the + -- routine always ignores the starting vertex, to prevent a spurious + -- self-cycle. + + elsif not Is_Start_Vertex + and then LGV_Sets.Contains (End_Vertices, Vertex) + then + Trace_Vertex (G, Vertex, Indent); + + Record_Cycle + (G => G, + Most_Significant_Edge => Most_Significant_Edge, + Invocation_Edge_Count => Invocation_Edge_Count, + Cycle_Path => Cycle_Path_Stack, + Indent => Indent); + + Has_Cycle := True; + Cycle_Count := Cycle_Count + 1; + return; + + -- Nothing to do when the vertex has already been deleted. This + -- indicates that all available cycles involving the vertex have + -- been discovered, and the vertex cannot contribute further to + -- the depth-first search. + + elsif LGV_Sets.Contains (Deleted_Vertices, Vertex) then + return; + + -- Nothing to do when the vertex has already been visited. This + -- indicates that the depth-first search initiated from some start + -- vertex already encountered this vertex, and the visited stack has + -- not been unrolled yet. + + elsif LGV_Sets.Contains (Visited_Set, Vertex) then + return; + end if; + + Trace_Vertex (G, Vertex, Indent); + + -- Mark the vertex as visited + + Visit + (Vertex => Vertex, + Visited_Set => Visited_Set, + Visited_Stack => Visited_Stack); + + -- Extend the depth-first search via all the edges to successors + + Iter := Iterate_Edges_To_Successors (G, Vertex); + while Has_Next (Iter) loop + Next (Iter, Edge); + + Find_Cycles_From_Successor + (G => G, + Edge => Edge, + End_Vertices => End_Vertices, + Deleted_Vertices => Deleted_Vertices, + + -- The edge may be more important than the most important edge + -- up to this point, thus "upgrading" the nature of the cycle, + -- and shifting its point of normalization. + + Most_Significant_Edge => + Highest_Precedence_Edge + (G => G, + Left => Edge, + Right => Most_Significant_Edge), + + -- The edge may be an invocation edge, in which case the count + -- of invocation edges increases by one. + + Invocation_Edge_Count => + Maximum_Invocation_Edge_Count + (G => G, + Edge => Edge, + Count => Invocation_Edge_Count), + + Cycle_Path_Stack => Cycle_Path_Stack, + Visited_Set => Visited_Set, + Visited_Stack => Visited_Stack, + Cycle_Count => Cycle_Count, + Cycle_Limit => Cycle_Limit, + Elaborate_All_Active => Elaborate_All_Active, + Has_Cycle => Successor_Has_Cycle, + Indent => Edge_Indent); + + Has_Cycle := Has_Cycle or Successor_Has_Cycle; + end loop; + + -- Visit the complementary vertex of the current vertex when pragma + -- Elaborate_All is in effect, or the current vertex is part of an + -- Elaborate_Body pair. + + if Elaborate_All_Active + or else Is_Vertex_With_Elaborate_Body (G, Vertex) + then + Complement := + Complementary_Vertex + (G => G, + Vertex => Vertex, + Force_Complement => Elaborate_All_Active); + + if Present (Complement) then + Find_Cycles_From_Vertex + (G => G, + Vertex => Complement, + End_Vertices => End_Vertices, + Deleted_Vertices => Deleted_Vertices, + Most_Significant_Edge => Most_Significant_Edge, + Invocation_Edge_Count => Invocation_Edge_Count, + Cycle_Path_Stack => Cycle_Path_Stack, + Visited_Set => Visited_Set, + Visited_Stack => Visited_Stack, + Cycle_Count => Cycle_Count, + Cycle_Limit => Cycle_Limit, + Elaborate_All_Active => Elaborate_All_Active, + Is_Start_Vertex => Is_Start_Vertex, + Has_Cycle => Complement_Has_Cycle, + Indent => Indent); + + Has_Cycle := Has_Cycle or Complement_Has_Cycle; + end if; + end if; + + -- The original algorithm clears the "marked stack" in two places: + -- + -- * When the depth-first search starting from the current vertex + -- discovers at least one cycle, and + -- + -- * When the depth-first search initiated from a start vertex + -- completes. + -- + -- The modified version handles both cases in one place. + + if Has_Cycle or else Is_Start_Vertex then + Unvisit + (Vertex => Vertex, + Visited_Set => Visited_Set, + Visited_Stack => Visited_Stack); + end if; + + -- Delete a start vertex from the graph once its depth-first search + -- completes. This action preserves the invariant where a cycle is + -- not rediscovered "later" in some permuted form. + + if Is_Start_Vertex then + LGV_Sets.Insert (Deleted_Vertices, Vertex); + end if; + end Find_Cycles_From_Vertex; + + ------------------------------ + -- Find_Cycles_In_Component -- + ------------------------------ + + procedure Find_Cycles_In_Component + (G : Library_Graph; + Comp : Component_Id; + Cycle_Count : in out Natural; + Cycle_Limit : Natural) + is + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + Num_Of_Vertices : constant Natural := + Number_Of_Component_Vertices (G, Comp); + + Elaborate_All_Active : constant Boolean := + Has_Elaborate_All_Edge (G, Comp); + -- The presence of an Elaborate_All edge within a component causes + -- all spec-body pairs to be treated as one vertex. + + Has_Cycle : Boolean; + Iter : Component_Vertex_Iterator; + Vertex : Library_Graph_Vertex_Id; + + Cycle_Path_Stack : LGE_Lists.Doubly_Linked_List := LGE_Lists.Nil; + -- The "point stack" of Tarjan's algorithm. The original maintains + -- a stack of vertices, however for diagnostic purposes using edges + -- is preferable. + + Deleted_Vertices : LGV_Sets.Membership_Set := LGV_Sets.Nil; + -- The original algorithm alters the graph by deleting vertices with + -- lower ordinals compared to some starting vertex. Since the graph + -- must remain intact for diagnostic purposes, vertices are instead + -- inserted in this set and treated as "deleted". + + End_Vertices : LGV_Sets.Membership_Set := LGV_Sets.Nil; + -- The original algorithm uses a single vertex to indicate the start + -- and end vertex of a cycle. The semantics of pragmas Elaborate_All + -- and Elaborate_Body increase this number by one. The end vertices + -- are added to this set and treated as "cycle-terminating". + + Visited_Set : LGV_Sets.Membership_Set := LGV_Sets.Nil; + -- The "mark" array of Tarjan's algorithm. Since the original visits + -- all vertices in increasing ordinal number 1 .. N, the array offers + -- a one-to-one mapping between a vertex and its "marked" state. The + -- modified version however visits vertices within components, where + -- their ordinals are not contiguous. Vertices are added to this set + -- and treated as "marked". + + Visited_Stack : LGV_Lists.Doubly_Linked_List := LGV_Lists.Nil; + -- The "marked stack" of Tarjan's algorithm + + begin + Trace_Component (G, Comp, No_Indentation); + + -- Initialize all component-level data structures + + Cycle_Path_Stack := LGE_Lists.Create; + Deleted_Vertices := LGV_Sets.Create (Num_Of_Vertices); + Visited_Set := LGV_Sets.Create (Num_Of_Vertices); + Visited_Stack := LGV_Lists.Create; + + -- The modified version does not use ordinals to visit vertices in + -- 1 .. N fashion. To preserve the invariant of the original, this + -- version deletes a vertex after its depth-first search completes. + -- The timing of the deletion is sound because all cycles through + -- that vertex have already been discovered, thus the vertex cannot + -- contribute to any cycles discovered "later" in the algorithm. + + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, Vertex); + + -- Construct the set of vertices (at most 2) that terminates a + -- potential cycle that starts from the current vertex. + + End_Vertices := + Cycle_End_Vertices + (G => G, + Vertex => Vertex, + Elaborate_All_Active => Elaborate_All_Active); + + -- The modified version maintains two additional attributes while + -- performing the depth-first search: + -- + -- * The most significant edge of the current potential cycle. + -- + -- * The number of invocation edges encountered along the path + -- of the current potential cycle. + -- + -- Both attributes are used in the heuristic that determines the + -- importance of cycles. + + Find_Cycles_From_Vertex + (G => G, + Vertex => Vertex, + End_Vertices => End_Vertices, + Deleted_Vertices => Deleted_Vertices, + Most_Significant_Edge => No_Library_Graph_Edge, + Invocation_Edge_Count => 0, + Cycle_Path_Stack => Cycle_Path_Stack, + Visited_Set => Visited_Set, + Visited_Stack => Visited_Stack, + Cycle_Count => Cycle_Count, + Cycle_Limit => Cycle_Limit, + Elaborate_All_Active => Elaborate_All_Active, + Is_Start_Vertex => True, + Has_Cycle => Has_Cycle, + Indent => Nested_Indentation); + + -- Destroy the cycle-terminating vertices because a new set must + -- be constructed for the next vertex. + + LGV_Sets.Destroy (End_Vertices); + end loop; + + -- Destroy all component-level data structures + + LGE_Lists.Destroy (Cycle_Path_Stack); + LGV_Sets.Destroy (Deleted_Vertices); + LGV_Sets.Destroy (Visited_Set); + LGV_Lists.Destroy (Visited_Stack); + end Find_Cycles_In_Component; + + --------------------------------------- + -- Find_First_Lower_Precedence_Cycle -- + --------------------------------------- + + function Find_First_Lower_Precedence_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Library_Graph_Cycle_Id + is + Current_Cycle : Library_Graph_Cycle_Id; + Iter : All_Cycle_Iterator; + Lesser_Cycle : Library_Graph_Cycle_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + -- Assume that there is no lesser cycle + + Lesser_Cycle := No_Library_Graph_Cycle; + + -- Find a cycle with a slightly lower precedence than the input + -- cycle. + -- + -- IMPORTANT: + -- + -- * The iterator must run to completion in order to unlock the + -- list of all cycles. + + Iter := Iterate_All_Cycles (G); + while Has_Next (Iter) loop + Next (Iter, Current_Cycle); + + if not Present (Lesser_Cycle) + and then Cycle_Precedence + (G => G, + Cycle => Cycle, + Compared_To => Current_Cycle) = Higher_Precedence + then + Lesser_Cycle := Current_Cycle; + end if; + end loop; + + return Lesser_Cycle; + end Find_First_Lower_Precedence_Cycle; + ------------------------------ -- Get_Component_Attributes -- ------------------------------ @@ -1658,23 +3198,37 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (Comp)); - return CA.Get (G.Component_Attributes, Comp); + return Component_Tables.Get (G.Component_Attributes, Comp); end Get_Component_Attributes; ------------------------ + -- Get_LGC_Attributes -- + ------------------------ + + function Get_LGC_Attributes + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Library_Graph_Cycle_Attributes + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return LGC_Tables.Get (G.Cycle_Attributes, Cycle); + end Get_LGC_Attributes; + + ------------------------ -- Get_LGE_Attributes -- ------------------------ function Get_LGE_Attributes - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) - return Library_Graph_Edge_Attributes + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Edge_Attributes is begin pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Edge)); - return EA.Get (G.Edge_Attributes, LGE_Id); + return LGE_Tables.Get (G.Edge_Attributes, Edge); end Get_LGE_Attributes; ------------------------ @@ -1683,41 +3237,154 @@ package body Bindo.Graphs is function Get_LGV_Attributes (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Attributes is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - return VA.Get (G.Vertex_Attributes, LGV_Id); + return LGV_Tables.Get (G.Vertex_Attributes, Vertex); end Get_LGV_Attributes; + ----------------------------- + -- Has_Elaborate_All_Cycle -- + ----------------------------- + + function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean is + Edge : Library_Graph_Edge_Id; + Iter : All_Edge_Iterator; + Seen : Boolean; + + begin + pragma Assert (Present (G)); + + -- Assume that no cyclic Elaborate_All edge has been seen + + Seen := False; + + -- IMPORTANT: + -- + -- * The iteration must run to completion in order to unlock the + -- graph. + + Iter := Iterate_All_Edges (G); + while Has_Next (Iter) loop + Next (Iter, Edge); + + if not Seen and then Is_Cyclic_Elaborate_All_Edge (G, Edge) then + Seen := True; + end if; + end loop; + + return Seen; + end Has_Elaborate_All_Cycle; + + ---------------------------- + -- Has_Elaborate_All_Edge -- + ---------------------------- + + function Has_Elaborate_All_Edge + (G : Library_Graph; + Comp : Component_Id) return Boolean + is + Has_Edge : Boolean; + Iter : Component_Vertex_Iterator; + Vertex : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + -- Assume that there is no Elaborate_All edge + + Has_Edge := False; + + -- IMPORTANT: + -- + -- * The iteration must run to completion in order to unlock the + -- component vertices. + + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, Vertex); + + Has_Edge := Has_Edge or else Has_Elaborate_All_Edge (G, Vertex); + end loop; + + return Has_Edge; + end Has_Elaborate_All_Edge; + + ---------------------------- + -- Has_Elaborate_All_Edge -- + ---------------------------- + + function Has_Elaborate_All_Edge + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + Edge : Library_Graph_Edge_Id; + Has_Edge : Boolean; + Iter : Edges_To_Successors_Iterator; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + -- Assume that there is no Elaborate_All edge + + Has_Edge := False; + + -- IMPORTANT: + -- + -- * The iteration must run to completion in order to unlock the + -- edges to successors. + + Iter := Iterate_Edges_To_Successors (G, Vertex); + while Has_Next (Iter) loop + Next (Iter, Edge); + + Has_Edge := + Has_Edge or else Is_Cyclic_Elaborate_All_Edge (G, Edge); + end loop; + + return Has_Edge; + end Has_Elaborate_All_Edge; + ------------------------ -- Has_Elaborate_Body -- ------------------------ function Has_Elaborate_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); + pragma Assert (Present (Vertex)); + U_Id : constant Unit_Id := Unit (G, Vertex); U_Rec : Unit_Record renames ALI.Units.Table (U_Id); begin - return U_Rec.Elaborate_Body; + -- Treat the spec and body as decoupled when switch -d_b (ignore the + -- effects of pragma Elaborate_Body) is in effect. + + return U_Rec.Elaborate_Body and not Debug_Flag_Underscore_B; end Has_Elaborate_Body; -------------- -- Has_Next -- -------------- + function Has_Next (Iter : All_Cycle_Iterator) return Boolean is + begin + return LGC_Lists.Has_Next (LGC_Lists.Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + function Has_Next (Iter : All_Edge_Iterator) return Boolean is begin return DG.Has_Next (DG.All_Edge_Iterator (Iter)); @@ -1754,11 +3421,64 @@ package body Bindo.Graphs is -- Has_Next -- -------------- + function Has_Next (Iter : Edges_Of_Cycle_Iterator) return Boolean is + begin + return LGE_Lists.Has_Next (LGE_Lists.Iterator (Iter)); + end Has_Next; + + -------------- + -- Has_Next -- + -------------- + function Has_Next (Iter : Edges_To_Successors_Iterator) return Boolean is begin return DG.Has_Next (DG.Outgoing_Edge_Iterator (Iter)); end Has_Next; + ----------------------------- + -- Has_No_Elaboration_Code -- + ----------------------------- + + function Has_No_Elaboration_Code + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return Has_No_Elaboration_Code (Unit (G, Vertex)); + end Has_No_Elaboration_Code; + + ----------------------------------------- + -- Hash_Library_Graph_Cycle_Attributes -- + ----------------------------------------- + + function Hash_Library_Graph_Cycle_Attributes + (Attrs : Library_Graph_Cycle_Attributes) return Bucket_Range_Type + is + Edge : Library_Graph_Edge_Id; + Hash : Bucket_Range_Type; + Iter : LGE_Lists.Iterator; + + begin + pragma Assert (LGE_Lists.Present (Attrs.Path)); + + -- The hash is obtained in the following manner: + -- + -- (((edge1 * 31) + edge2) * 31) + edgeN + + Hash := 0; + Iter := LGE_Lists.Iterate (Attrs.Path); + while LGE_Lists.Has_Next (Iter) loop + LGE_Lists.Next (Iter, Edge); + + Hash := (Hash * 31) + Bucket_Range_Type (Edge); + end loop; + + return Hash; + end Hash_Library_Graph_Cycle_Attributes; + ----------------------------------------- -- Hash_Predecessor_Successor_Relation -- ----------------------------------------- @@ -1776,21 +3496,106 @@ package body Bindo.Graphs is Bucket_Range_Type (Rel.Successor)); end Hash_Predecessor_Successor_Relation; + ------------------------------ + -- Highest_Precedence_Cycle -- + ------------------------------ + + function Highest_Precedence_Cycle + (G : Library_Graph) return Library_Graph_Cycle_Id + is + begin + pragma Assert (Present (G)); + pragma Assert (LGC_Lists.Present (G.Cycles)); + + if LGC_Lists.Is_Empty (G.Cycles) then + return No_Library_Graph_Cycle; + + -- The highest precedence cycle is always the first in the list of + -- all cycles. + + else + return LGC_Lists.First (G.Cycles); + end if; + end Highest_Precedence_Cycle; + + ----------------------------- + -- Highest_Precedence_Edge -- + ----------------------------- + + function Highest_Precedence_Edge + (G : Library_Graph; + Left : Library_Graph_Edge_Id; + Right : Library_Graph_Edge_Id) return Library_Graph_Edge_Id + is + Edge_Prec : Precedence_Kind; + + begin + pragma Assert (Present (G)); + + -- Both edges are available, pick the one with highest precedence + + if Present (Left) and then Present (Right) then + Edge_Prec := + Edge_Precedence + (G => G, + Edge => Left, + Compared_To => Right); + + if Edge_Prec = Higher_Precedence then + return Left; + + -- The precedence rules for edges are such that no two edges can + -- ever have the same precedence. + + else + pragma Assert (Edge_Prec = Lower_Precedence); + return Right; + end if; + + -- Otherwise at least one edge must be present + + elsif Present (Left) then + return Left; + + else + pragma Assert (Present (Right)); + + return Right; + end if; + end Highest_Precedence_Edge; + -------------------------- -- In_Elaboration_Order -- -------------------------- function In_Elaboration_Order (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - return Get_LGV_Attributes (G, LGV_Id).In_Elaboration_Order; + return Get_LGV_Attributes (G, Vertex).In_Elaboration_Order; end In_Elaboration_Order; + ----------------------- + -- In_Same_Component -- + ----------------------- + + function In_Same_Component + (G : Library_Graph; + Left : Library_Graph_Vertex_Id; + Right : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Left)); + pragma Assert (Present (Right)); + + return Component (G, Left) = Component (G, Right); + end In_Same_Component; + ---------------------------------------- -- Increment_Library_Graph_Edge_Count -- ---------------------------------------- @@ -1813,7 +3618,8 @@ package body Bindo.Graphs is procedure Increment_Pending_Predecessors (G : Library_Graph; - Comp : Component_Id) + Comp : Component_Id; + Edge : Library_Graph_Edge_Id) is Attrs : Component_Attributes; @@ -1822,7 +3628,13 @@ package body Bindo.Graphs is pragma Assert (Present (Comp)); Attrs := Get_Component_Attributes (G, Comp); - Attrs.Pending_Predecessors := Attrs.Pending_Predecessors + 1; + + Update_Pending_Predecessors + (Strong_Predecessors => Attrs.Pending_Strong_Predecessors, + Weak_Predecessors => Attrs.Pending_Weak_Predecessors, + Update_Weak => Is_Invocation_Edge (G, Edge), + Value => 1); + Set_Component_Attributes (G, Comp, Attrs); end Increment_Pending_Predecessors; @@ -1832,17 +3644,24 @@ package body Bindo.Graphs is procedure Increment_Pending_Predecessors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id; + Edge : Library_Graph_Edge_Id) is Attrs : Library_Graph_Vertex_Attributes; begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - Attrs := Get_LGV_Attributes (G, LGV_Id); - Attrs.Pending_Predecessors := Attrs.Pending_Predecessors + 1; - Set_LGV_Attributes (G, LGV_Id, Attrs); + Attrs := Get_LGV_Attributes (G, Vertex); + + Update_Pending_Predecessors + (Strong_Predecessors => Attrs.Pending_Strong_Predecessors, + Weak_Predecessors => Attrs.Pending_Weak_Predecessors, + Update_Weak => Is_Invocation_Edge (G, Edge), + Value => 1); + + Set_LGV_Attributes (G, Vertex, Attrs); end Increment_Pending_Predecessors; --------------------------- @@ -1854,30 +3673,60 @@ package body Bindo.Graphs is pragma Assert (Present (G)); -- The graph already contains a set of components. Reinitialize - -- them in order to accomodate the new set of components about to + -- them in order to accommodate the new set of components about to -- be computed. if Number_Of_Components (G) > 0 then - CA.Destroy (G.Component_Attributes); - G.Component_Attributes := CA.Create (Number_Of_Vertices (G)); + Component_Tables.Destroy (G.Component_Attributes); + + G.Component_Attributes := + Component_Tables.Create (Number_Of_Vertices (G)); end if; end Initialize_Components; + --------------------------- + -- Invocation_Edge_Count -- + --------------------------- + + function Invocation_Edge_Count + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return Get_LGC_Attributes (G, Cycle).Invocation_Edge_Count; + end Invocation_Edge_Count; + + ------------------------------- + -- Invocation_Graph_Encoding -- + ------------------------------- + + function Invocation_Graph_Encoding + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) + return Invocation_Graph_Encoding_Kind + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return Invocation_Graph_Encoding (Unit (G, Vertex)); + end Invocation_Graph_Encoding; + ------------- -- Is_Body -- ------------- function Is_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); + pragma Assert (Present (Vertex)); + U_Id : constant Unit_Id := Unit (G, Vertex); U_Rec : Unit_Record renames ALI.Units.Table (U_Id); begin @@ -1890,19 +3739,17 @@ package body Bindo.Graphs is function Is_Body_Of_Spec_With_Elaborate_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is - Spec_LGV_Id : Library_Graph_Vertex_Id; - begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - if Is_Body_With_Spec (G, LGV_Id) then - Spec_LGV_Id := Proper_Spec (G, LGV_Id); - pragma Assert (Present (Spec_LGV_Id)); - - return Is_Spec_With_Elaborate_Body (G, Spec_LGV_Id); + if Is_Body_With_Spec (G, Vertex) then + return + Is_Spec_With_Elaborate_Body + (G => G, + Vertex => Proper_Spec (G, Vertex)); end if; return False; @@ -1914,21 +3761,176 @@ package body Bindo.Graphs is function Is_Body_With_Spec (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); + pragma Assert (Present (Vertex)); + U_Id : constant Unit_Id := Unit (G, Vertex); U_Rec : Unit_Record renames ALI.Units.Table (U_Id); begin return U_Rec.Utype = Is_Body; end Is_Body_With_Spec; + ------------------------------ + -- Is_Cycle_Initiating_Edge -- + ------------------------------ + + function Is_Cycle_Initiating_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Cyclic_Elaborate_All_Edge (G, Edge) + or else Is_Cyclic_Elaborate_Body_Edge (G, Edge) + or else Is_Cyclic_Elaborate_Edge (G, Edge) + or else Is_Cyclic_Forced_Edge (G, Edge) + or else Is_Cyclic_Invocation_Edge (G, Edge); + end Is_Cycle_Initiating_Edge; + + -------------------- + -- Is_Cyclic_Edge -- + -------------------- + + function Is_Cyclic_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Cycle_Initiating_Edge (G, Edge) + or else Is_Cyclic_With_Edge (G, Edge); + end Is_Cyclic_Edge; + + ---------------------------------- + -- Is_Cyclic_Elaborate_All_Edge -- + ---------------------------------- + + function Is_Cyclic_Elaborate_All_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Elaborate_All_Edge (G, Edge) + and then Links_Vertices_In_Same_Component (G, Edge); + end Is_Cyclic_Elaborate_All_Edge; + + ----------------------------------- + -- Is_Cyclic_Elaborate_Body_Edge -- + ----------------------------------- + + function Is_Cyclic_Elaborate_Body_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Elaborate_Body_Edge (G, Edge) + and then Links_Vertices_In_Same_Component (G, Edge); + end Is_Cyclic_Elaborate_Body_Edge; + + ------------------------------ + -- Is_Cyclic_Elaborate_Edge -- + ------------------------------ + + function Is_Cyclic_Elaborate_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Elaborate_Edge (G, Edge) + and then Links_Vertices_In_Same_Component (G, Edge); + end Is_Cyclic_Elaborate_Edge; + + --------------------------- + -- Is_Cyclic_Forced_Edge -- + --------------------------- + + function Is_Cyclic_Forced_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Forced_Edge (G, Edge) + and then Links_Vertices_In_Same_Component (G, Edge); + end Is_Cyclic_Forced_Edge; + + ------------------------------- + -- Is_Cyclic_Invocation_Edge -- + ------------------------------- + + function Is_Cyclic_Invocation_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Invocation_Edge (G, Edge) + and then Links_Vertices_In_Same_Component (G, Edge); + end Is_Cyclic_Invocation_Edge; + + ------------------------- + -- Is_Cyclic_With_Edge -- + ------------------------- + + function Is_Cyclic_With_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + -- Ignore Elaborate_Body edges because they also appear as with + -- edges, but have special successors. + + return + Is_With_Edge (G, Edge) + and then Links_Vertices_In_Same_Component (G, Edge) + and then not Is_Elaborate_Body_Edge (G, Edge); + end Is_Cyclic_With_Edge; + + ------------------------------- + -- Is_Dynamically_Elaborated -- + ------------------------------- + + function Is_Dynamically_Elaborated + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return Is_Dynamically_Elaborated (Unit (G, Vertex)); + end Is_Dynamically_Elaborated; + ----------------------------- -- Is_Elaborable_Component -- ----------------------------- @@ -1941,12 +3943,14 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (Comp)); - -- A component can be elaborated when + -- A component is elaborable when: -- - -- * The component is no longer wanting on any of its predecessors - -- to be elaborated. + -- * It is not waiting on strong predecessors, and + -- * It is not waiting on weak predecessors - return Pending_Predecessors (G, Comp) = 0; + return + Pending_Strong_Predecessors (G, Comp) = 0 + and then Pending_Weak_Predecessors (G, Comp) = 0; end Is_Elaborable_Component; -------------------------- @@ -1955,104 +3959,132 @@ package body Bindo.Graphs is function Is_Elaborable_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is - Check_LGV_Id : Library_Graph_Vertex_Id; - - begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - Check_LGV_Id := LGV_Id; + Complement : constant Library_Graph_Vertex_Id := + Complementary_Vertex + (G => G, + Vertex => Vertex, + Force_Complement => False); - -- A spec-body pair where the spec carries pragma Elaborate_Body must - -- be treated as one vertex for elaboration purposes. Use the spec as - -- the point of reference for the composite vertex. + Strong_Preds : Natural; + Weak_Preds : Natural; - if Is_Body_Of_Spec_With_Elaborate_Body (G, Check_LGV_Id) then - Check_LGV_Id := Proper_Spec (G, Check_LGV_Id); - pragma Assert (Present (Check_LGV_Id)); + begin + -- A vertex is elaborable when: + -- + -- * It has not been elaborated yet, and + -- * The complement vertex of an Elaborate_Body pair has not been + -- elaborated yet, and + -- * It resides within an elaborable component, and + -- * It is not waiting on strong predecessors, and + -- * It is not waiting on weak predecessors + + if In_Elaboration_Order (G, Vertex) then + return False; + + elsif Present (Complement) + and then In_Elaboration_Order (G, Complement) + then + return False; + + elsif not Is_Elaborable_Component (G, Component (G, Vertex)) then + return False; end if; - return - Is_Elaborable_Vertex - (G => G, - LGV_Id => Check_LGV_Id, - Predecessors => 0); + Pending_Predecessors_For_Elaboration + (G => G, + Vertex => Vertex, + Strong_Preds => Strong_Preds, + Weak_Preds => Weak_Preds); + + return Strong_Preds = 0 and then Weak_Preds = 0; end Is_Elaborable_Vertex; - -------------------------- - -- Is_Elaborable_Vertex -- - -------------------------- + --------------------------- + -- Is_Elaborate_All_Edge -- + --------------------------- - function Is_Elaborable_Vertex - (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; - Predecessors : Natural) return Boolean + function Is_Elaborate_All_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean is + begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - Comp : constant Component_Id := Component (G, LGV_Id); + pragma Assert (Present (Edge)); - pragma Assert (Present (Comp)); + return Kind (G, Edge) = Elaborate_All_Edge; + end Is_Elaborate_All_Edge; - Body_LGV_Id : Library_Graph_Vertex_Id; + ---------------------------- + -- Is_Elaborate_Body_Edge -- + ---------------------------- + function Is_Elaborate_Body_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is begin - -- The vertex must not be re-elaborated once it has been elaborated - - if In_Elaboration_Order (G, LGV_Id) then - return False; - - -- The vertex must not be waiting on more precedessors than requested - -- to be elaborated. - - elsif Pending_Predecessors (G, LGV_Id) /= Predecessors then - return False; + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); - -- The component where the vertex resides must not be waiting on any - -- of its precedessors to be elaborated. + return + Kind (G, Edge) = With_Edge + and then Is_Vertex_With_Elaborate_Body (G, Successor (G, Edge)); + end Is_Elaborate_Body_Edge; - elsif not Is_Elaborable_Component (G, Comp) then - return False; + ----------------------- + -- Is_Elaborate_Edge -- + ----------------------- - -- The vertex denotes a spec with a completing body, and is subject - -- to pragma Elaborate_Body. The body must be elaborable for the - -- vertex to be elaborated. Account for the sole predecessor of the - -- body which is the vertex itself. + function Is_Elaborate_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); - elsif Is_Spec_With_Elaborate_Body (G, LGV_Id) then - Body_LGV_Id := Proper_Body (G, LGV_Id); - pragma Assert (Present (Body_LGV_Id)); + return Kind (G, Edge) = Elaborate_Edge; + end Is_Elaborate_Edge; - return - Is_Elaborable_Vertex - (G => G, - LGV_Id => Body_LGV_Id, - Predecessors => 1); - end if; + ---------------------------- + -- Is_Elaborate_Body_Pair -- + ---------------------------- - -- At this point it is known that the vertex can be elaborated + function Is_Elaborate_Body_Pair + (G : Library_Graph; + Spec_Vertex : Library_Graph_Vertex_Id; + Body_Vertex : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Spec_Vertex)); + pragma Assert (Present (Body_Vertex)); - return True; - end Is_Elaborable_Vertex; + return + Is_Spec_With_Elaborate_Body (G, Spec_Vertex) + and then Is_Body_Of_Spec_With_Elaborate_Body (G, Body_Vertex) + and then Proper_Body (G, Spec_Vertex) = Body_Vertex; + end Is_Elaborate_Body_Pair; - ------------------------------------------------ - -- Is_Existing_Predecessor_Successor_Relation -- - ------------------------------------------------ + -------------------- + -- Is_Forced_Edge -- + -------------------- - function Is_Existing_Predecessor_Successor_Relation - (G : Library_Graph; - Rel : Predecessor_Successor_Relation) return Boolean + function Is_Forced_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean is begin pragma Assert (Present (G)); - pragma Assert (Present (Rel.Predecessor)); - pragma Assert (Present (Rel.Successor)); + pragma Assert (Present (Edge)); - return PS.Contains (G.Relations, Rel); - end Is_Existing_Predecessor_Successor_Relation; + return Kind (G, Edge) = Forced_Edge; + end Is_Forced_Edge; ---------------------- -- Is_Internal_Unit -- @@ -2060,18 +4092,29 @@ package body Bindo.Graphs is function Is_Internal_Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is + begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - U_Id : constant Unit_Id := Unit (G, LGV_Id); + return Is_Internal_Unit (Unit (G, Vertex)); + end Is_Internal_Unit; - pragma Assert (Present (U_Id)); + ------------------------ + -- Is_Invocation_Edge -- + ------------------------ + function Is_Invocation_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is begin - return Is_Internal_Unit (U_Id); - end Is_Internal_Unit; + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return Kind (G, Edge) = Invocation_Edge; + end Is_Invocation_Edge; ------------------------ -- Is_Predefined_Unit -- @@ -2079,17 +4122,13 @@ package body Bindo.Graphs is function Is_Predefined_Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is + begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - U_Id : constant Unit_Id := Unit (G, LGV_Id); + pragma Assert (Present (Vertex)); - pragma Assert (Present (U_Id)); - - begin - return Is_Predefined_Unit (U_Id); + return Is_Predefined_Unit (Unit (G, Vertex)); end Is_Predefined_Unit; --------------------------- @@ -2098,57 +4137,79 @@ package body Bindo.Graphs is function Is_Preelaborated_Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); + pragma Assert (Present (Vertex)); + U_Id : constant Unit_Id := Unit (G, Vertex); U_Rec : Unit_Record renames ALI.Units.Table (U_Id); begin return U_Rec.Preelab or else U_Rec.Pure; end Is_Preelaborated_Unit; + ---------------------- + -- Is_Recorded_Edge -- + ---------------------- + + function Is_Recorded_Edge + (G : Library_Graph; + Rel : Predecessor_Successor_Relation) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Rel.Predecessor)); + pragma Assert (Present (Rel.Successor)); + + return RE_Sets.Contains (G.Recorded_Edges, Rel); + end Is_Recorded_Edge; + ------------- -- Is_Spec -- ------------- function Is_Spec (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); + pragma Assert (Present (Vertex)); + U_Id : constant Unit_Id := Unit (G, Vertex); U_Rec : Unit_Record renames ALI.Units.Table (U_Id); begin return U_Rec.Utype = Is_Spec or else U_Rec.Utype = Is_Spec_Only; end Is_Spec; + ------------------------------ + -- Is_Spec_Before_Body_Edge -- + ------------------------------ + + function Is_Spec_Before_Body_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return Kind (G, Edge) = Spec_Before_Body_Edge; + end Is_Spec_Before_Body_Edge; + ----------------------- -- Is_Spec_With_Body -- ----------------------- function Is_Spec_With_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); - - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); + pragma Assert (Present (Vertex)); + U_Id : constant Unit_Id := Unit (G, Vertex); U_Rec : Unit_Record renames ALI.Units.Table (U_Id); begin @@ -2161,17 +4222,131 @@ package body Bindo.Graphs is function Is_Spec_With_Elaborate_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); return - Is_Spec_With_Body (G, LGV_Id) - and then Has_Elaborate_Body (G, LGV_Id); + Is_Spec_With_Body (G, Vertex) + and then Has_Elaborate_Body (G, Vertex); end Is_Spec_With_Elaborate_Body; + ------------------------------ + -- Is_Static_Successor_Edge -- + ------------------------------ + + function Is_Static_Successor_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return + Is_Invocation_Edge (G, Edge) + and then not Is_Dynamically_Elaborated (G, Successor (G, Edge)); + end Is_Static_Successor_Edge; + + ----------------------------------- + -- Is_Vertex_With_Elaborate_Body -- + ----------------------------------- + + function Is_Vertex_With_Elaborate_Body + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return + Is_Spec_With_Elaborate_Body (G, Vertex) + or else + Is_Body_Of_Spec_With_Elaborate_Body (G, Vertex); + end Is_Vertex_With_Elaborate_Body; + + --------------------------------- + -- Is_Weakly_Elaborable_Vertex -- + ---------------------------------- + + function Is_Weakly_Elaborable_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean + is + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + Complement : constant Library_Graph_Vertex_Id := + Complementary_Vertex + (G => G, + Vertex => Vertex, + Force_Complement => False); + + Strong_Preds : Natural; + Weak_Preds : Natural; + + begin + -- A vertex is weakly elaborable when: + -- + -- * It has not been elaborated yet, and + -- * The complement vertex of an Elaborate_Body pair has not been + -- elaborated yet, and + -- * It resides within an elaborable component, and + -- * It is not waiting on strong predecessors, and + -- * It is waiting on at least one weak predecessor + + if In_Elaboration_Order (G, Vertex) then + return False; + + elsif Present (Complement) + and then In_Elaboration_Order (G, Complement) + then + return False; + + elsif not Is_Elaborable_Component (G, Component (G, Vertex)) then + return False; + end if; + + Pending_Predecessors_For_Elaboration + (G => G, + Vertex => Vertex, + Strong_Preds => Strong_Preds, + Weak_Preds => Weak_Preds); + + return Strong_Preds = 0 and then Weak_Preds >= 1; + end Is_Weakly_Elaborable_Vertex; + + ------------------ + -- Is_With_Edge -- + ------------------ + + function Is_With_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return Kind (G, Edge) = With_Edge; + end Is_With_Edge; + + ------------------------ + -- Iterate_All_Cycles -- + ------------------------ + + function Iterate_All_Cycles + (G : Library_Graph) return All_Cycle_Iterator + is + begin + pragma Assert (Present (G)); + + return All_Cycle_Iterator (LGC_Lists.Iterate (G.Cycles)); + end Iterate_All_Cycles; + ----------------------- -- Iterate_All_Edges -- ----------------------- @@ -2228,22 +4403,36 @@ package body Bindo.Graphs is (DG.Iterate_Component_Vertices (G.Graph, Comp)); end Iterate_Component_Vertices; + ---------------------------- + -- Iterate_Edges_Of_Cycle -- + ---------------------------- + + function Iterate_Edges_Of_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Edges_Of_Cycle_Iterator + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return Edges_Of_Cycle_Iterator (LGE_Lists.Iterate (Path (G, Cycle))); + end Iterate_Edges_Of_Cycle; + --------------------------------- -- Iterate_Edges_To_Successors -- --------------------------------- function Iterate_Edges_To_Successors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) - return Edges_To_Successors_Iterator + Vertex : Library_Graph_Vertex_Id) return Edges_To_Successors_Iterator is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); return Edges_To_Successors_Iterator - (DG.Iterate_Outgoing_Edges (G.Graph, LGV_Id)); + (DG.Iterate_Outgoing_Edges (G.Graph, Vertex)); end Iterate_Edges_To_Successors; ---------- @@ -2252,15 +4441,45 @@ package body Bindo.Graphs is function Kind (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind + Cycle : Library_Graph_Cycle_Id) return Library_Graph_Cycle_Kind is begin pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Cycle)); - return Get_LGE_Attributes (G, LGE_Id).Kind; + return Get_LGC_Attributes (G, Cycle).Kind; end Kind; + ---------- + -- Kind -- + ---------- + + function Kind + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + return Get_LGE_Attributes (G, Edge).Kind; + end Kind; + + ------------ + -- Length -- + ------------ + + function Length + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return LGE_Lists.Size (Path (G, Cycle)); + end Length; + ------------------------------ -- Library_Graph_Edge_Count -- ------------------------------ @@ -2280,27 +4499,45 @@ package body Bindo.Graphs is -------------------------------------- function Links_Vertices_In_Same_Component - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Boolean + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean is + begin pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Edge)); - Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); - Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); + -- An edge is part of a cycle when both the successor and predecessor + -- reside in the same component. - pragma Assert (Present (Pred)); - pragma Assert (Present (Succ)); + return + In_Same_Component + (G => G, + Left => Predecessor (G, Edge), + Right => Successor (G, Edge)); + end Links_Vertices_In_Same_Component; - Pred_Comp : constant Component_Id := Component (G, Pred); - Succ_Comp : constant Component_Id := Component (G, Succ); + ----------------------------------- + -- Maximum_Invocation_Edge_Count -- + ----------------------------------- - pragma Assert (Present (Pred_Comp)); - pragma Assert (Present (Succ_Comp)); + function Maximum_Invocation_Edge_Count + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + Count : Natural) return Natural + is + New_Count : Natural; begin - return Pred_Comp = Succ_Comp; - end Links_Vertices_In_Same_Component; + pragma Assert (Present (G)); + + New_Count := Count; + + if Present (Edge) and then Is_Invocation_Edge (G, Edge) then + New_Count := New_Count + 1; + end if; + + return New_Count; + end Maximum_Invocation_Edge_Count; ---------- -- Name -- @@ -2308,17 +4545,13 @@ package body Bindo.Graphs is function Name (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Unit_Name_Type + Vertex : Library_Graph_Vertex_Id) return Unit_Name_Type is + begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); - - begin - return Name (U_Id); + return Name (Unit (G, Vertex)); end Name; ----------------------- @@ -2327,29 +4560,37 @@ package body Bindo.Graphs is function Needs_Elaboration (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean + Vertex : Library_Graph_Vertex_Id) return Boolean is + begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - U_Id : constant Unit_Id := Unit (G, LGV_Id); + return Needs_Elaboration (Unit (G, Vertex)); + end Needs_Elaboration; - pragma Assert (Present (U_Id)); + ---------- + -- Next -- + ---------- + procedure Next + (Iter : in out All_Cycle_Iterator; + Cycle : out Library_Graph_Cycle_Id) + is begin - return Needs_Elaboration (U_Id); - end Needs_Elaboration; + LGC_Lists.Next (LGC_Lists.Iterator (Iter), Cycle); + end Next; ---------- -- Next -- ---------- procedure Next - (Iter : in out All_Edge_Iterator; - LGE_Id : out Library_Graph_Edge_Id) + (Iter : in out All_Edge_Iterator; + Edge : out Library_Graph_Edge_Id) is begin - DG.Next (DG.All_Edge_Iterator (Iter), LGE_Id); + DG.Next (DG.All_Edge_Iterator (Iter), Edge); end Next; ---------- @@ -2358,10 +4599,22 @@ package body Bindo.Graphs is procedure Next (Iter : in out All_Vertex_Iterator; - LGV_Id : out Library_Graph_Vertex_Id) + Vertex : out Library_Graph_Vertex_Id) is begin - DG.Next (DG.All_Vertex_Iterator (Iter), LGV_Id); + DG.Next (DG.All_Vertex_Iterator (Iter), Vertex); + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Edges_Of_Cycle_Iterator; + Edge : out Library_Graph_Edge_Id) + is + begin + LGE_Lists.Next (LGE_Lists.Iterator (Iter), Edge); end Next; ---------- @@ -2381,11 +4634,11 @@ package body Bindo.Graphs is ---------- procedure Next - (Iter : in out Edges_To_Successors_Iterator; - LGE_Id : out Library_Graph_Edge_Id) + (Iter : in out Edges_To_Successors_Iterator; + Edge : out Library_Graph_Edge_Id) is begin - DG.Next (DG.Outgoing_Edge_Iterator (Iter), LGE_Id); + DG.Next (DG.Outgoing_Edge_Iterator (Iter), Edge); end Next; ---------- @@ -2394,12 +4647,51 @@ package body Bindo.Graphs is procedure Next (Iter : in out Component_Vertex_Iterator; - LGV_Id : out Library_Graph_Vertex_Id) + Vertex : out Library_Graph_Vertex_Id) is begin - DG.Next (DG.Component_Vertex_Iterator (Iter), LGV_Id); + DG.Next (DG.Component_Vertex_Iterator (Iter), Vertex); end Next; + -------------------------- + -- Normalize_Cycle_Path -- + -------------------------- + + procedure Normalize_Cycle_Path + (Cycle_Path : LGE_Lists.Doubly_Linked_List; + Most_Significant_Edge : Library_Graph_Edge_Id) + is + Edge : Library_Graph_Edge_Id; + + begin + pragma Assert (LGE_Lists.Present (Cycle_Path)); + pragma Assert (Present (Most_Significant_Edge)); + + -- Perform at most |Cycle_Path| rotations in case the cycle is + -- malformed and the significant edge does not appear within. + + for Rotation in 1 .. LGE_Lists.Size (Cycle_Path) loop + Edge := LGE_Lists.First (Cycle_Path); + + -- The cycle is already rotated such that the most significant + -- edge is first. + + if Edge = Most_Significant_Edge then + return; + + -- Otherwise rotate the cycle by relocating the current edge from + -- the start to the end of the path. This preserves the order of + -- the path. + + else + LGE_Lists.Delete_First (Cycle_Path); + LGE_Lists.Append (Cycle_Path, Edge); + end if; + end loop; + + pragma Assert (False); + end Normalize_Cycle_Path; + ---------------------------------- -- Number_Of_Component_Vertices -- ---------------------------------- @@ -2426,6 +4718,17 @@ package body Bindo.Graphs is return DG.Number_Of_Components (G.Graph); end Number_Of_Components; + ---------------------- + -- Number_Of_Cycles -- + ---------------------- + + function Number_Of_Cycles (G : Library_Graph) return Natural is + begin + pragma Assert (Present (G)); + + return LGC_Lists.Size (G.Cycles); + end Number_Of_Cycles; + --------------------- -- Number_Of_Edges -- --------------------- @@ -2443,12 +4746,12 @@ package body Bindo.Graphs is function Number_Of_Edges_To_Successors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Natural + Vertex : Library_Graph_Vertex_Id) return Natural is begin pragma Assert (Present (G)); - return DG.Number_Of_Outgoing_Edges (G.Graph, LGV_Id); + return DG.Number_Of_Outgoing_Edges (G.Graph, Vertex); end Number_Of_Edges_To_Successors; ------------------------ @@ -2462,11 +4765,131 @@ package body Bindo.Graphs is return DG.Number_Of_Vertices (G.Graph); end Number_Of_Vertices; - -------------------------- - -- Pending_Predecessors -- - -------------------------- + ----------------- + -- Order_Cycle -- + ----------------- + + procedure Order_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) + is + Lesser_Cycle : Library_Graph_Cycle_Id; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + pragma Assert (LGC_Lists.Present (G.Cycles)); + + -- The input cycle is the first to be inserted + + if LGC_Lists.Is_Empty (G.Cycles) then + LGC_Lists.Prepend (G.Cycles, Cycle); + + -- Otherwise the list of all cycles contains at least one cycle. + -- Insert the input cycle based on its precedence. + + else + Lesser_Cycle := Find_First_Lower_Precedence_Cycle (G, Cycle); + + -- The list contains at least one cycle, and the input cycle has a + -- higher precedence compared to some cycle in the list. + + if Present (Lesser_Cycle) then + LGC_Lists.Insert_Before + (L => G.Cycles, + Before => Lesser_Cycle, + Elem => Cycle); + + -- Otherwise the input cycle has the lowest precedence among all + -- cycles. + + else + LGC_Lists.Append (G.Cycles, Cycle); + end if; + end if; + end Order_Cycle; + + ---------- + -- Path -- + ---------- + + function Path + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return LGE_Lists.Doubly_Linked_List + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + return Get_LGC_Attributes (G, Cycle).Path; + end Path; + + ------------------------------------------ + -- Pending_Predecessors_For_Elaboration -- + ------------------------------------------ + + procedure Pending_Predecessors_For_Elaboration + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Strong_Preds : out Natural; + Weak_Preds : out Natural) + is + Complement : Library_Graph_Vertex_Id; + Spec_Vertex : Library_Graph_Vertex_Id; + Total_Strong_Preds : Natural; + Total_Weak_Preds : Natural; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); - function Pending_Predecessors + Total_Strong_Preds := Pending_Strong_Predecessors (G, Vertex); + Total_Weak_Preds := Pending_Weak_Predecessors (G, Vertex); + + -- Assume that there is no complementary vertex that needs to be + -- examined. + + Complement := No_Library_Graph_Vertex; + Spec_Vertex := No_Library_Graph_Vertex; + + if Is_Body_Of_Spec_With_Elaborate_Body (G, Vertex) then + Complement := Proper_Spec (G, Vertex); + Spec_Vertex := Complement; + + elsif Is_Spec_With_Elaborate_Body (G, Vertex) then + Complement := Proper_Body (G, Vertex); + Spec_Vertex := Vertex; + end if; + + -- The vertex is part of an Elaborate_Body pair. Take into account + -- the strong and weak predecessors of the complementary vertex. + + if Present (Complement) then + Total_Strong_Preds := + Pending_Strong_Predecessors (G, Complement) + Total_Strong_Preds; + Total_Weak_Preds := + Pending_Weak_Predecessors (G, Complement) + Total_Weak_Preds; + + -- The body of an Elaborate_Body pair is the successor of a strong + -- edge where the predecessor is the spec. This edge must not be + -- considered for elaboration purposes because the pair is treated + -- as one vertex. Account for the edge only when the spec has not + -- been elaborated yet. + + if not In_Elaboration_Order (G, Spec_Vertex) then + Total_Strong_Preds := Total_Strong_Preds - 1; + end if; + end if; + + Strong_Preds := Total_Strong_Preds; + Weak_Preds := Total_Weak_Preds; + end Pending_Predecessors_For_Elaboration; + + --------------------------------- + -- Pending_Strong_Predecessors -- + --------------------------------- + + function Pending_Strong_Predecessors (G : Library_Graph; Comp : Component_Id) return Natural is @@ -2474,37 +4897,67 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (Comp)); - return Get_Component_Attributes (G, Comp).Pending_Predecessors; - end Pending_Predecessors; + return Get_Component_Attributes (G, Comp).Pending_Strong_Predecessors; + end Pending_Strong_Predecessors; - -------------------------- - -- Pending_Predecessors -- - -------------------------- + --------------------------------- + -- Pending_Strong_Predecessors -- + --------------------------------- + + function Pending_Strong_Predecessors + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + return Get_LGV_Attributes (G, Vertex).Pending_Strong_Predecessors; + end Pending_Strong_Predecessors; + + ------------------------------- + -- Pending_Weak_Predecessors -- + ------------------------------- + + function Pending_Weak_Predecessors + (G : Library_Graph; + Comp : Component_Id) return Natural + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + return Get_Component_Attributes (G, Comp).Pending_Weak_Predecessors; + end Pending_Weak_Predecessors; + + ------------------------------- + -- Pending_Weak_Predecessors -- + ------------------------------- - function Pending_Predecessors + function Pending_Weak_Predecessors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Natural + Vertex : Library_Graph_Vertex_Id) return Natural is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - return Get_LGV_Attributes (G, LGV_Id).Pending_Predecessors; - end Pending_Predecessors; + return Get_LGV_Attributes (G, Vertex).Pending_Weak_Predecessors; + end Pending_Weak_Predecessors; ----------------- -- Predecessor -- ----------------- function Predecessor - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Edge)); - return DG.Source_Vertex (G.Graph, LGE_Id); + return DG.Source_Vertex (G.Graph, Edge); end Predecessor; ------------- @@ -2522,23 +4975,23 @@ package body Bindo.Graphs is function Proper_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); -- When the vertex denotes a spec with a completing body, return the -- body. - if Is_Spec_With_Body (G, LGV_Id) then - return Corresponding_Item (G, LGV_Id); + if Is_Spec_With_Body (G, Vertex) then + return Corresponding_Item (G, Vertex); -- Otherwise the vertex must be a body else - pragma Assert (Is_Body (G, LGV_Id)); - return LGV_Id; + pragma Assert (Is_Body (G, Vertex)); + return Vertex; end if; end Proper_Body; @@ -2548,26 +5001,102 @@ package body Bindo.Graphs is function Proper_Spec (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); -- When the vertex denotes a body that completes a spec, return the -- spec. - if Is_Body_With_Spec (G, LGV_Id) then - return Corresponding_Item (G, LGV_Id); + if Is_Body_With_Spec (G, Vertex) then + return Corresponding_Item (G, Vertex); -- Otherwise the vertex must denote a spec else - pragma Assert (Is_Spec (G, LGV_Id)); - return LGV_Id; + pragma Assert (Is_Spec (G, Vertex)); + return Vertex; end if; end Proper_Spec; + ------------------ + -- Record_Cycle -- + ------------------ + + procedure Record_Cycle + (G : Library_Graph; + Most_Significant_Edge : Library_Graph_Edge_Id; + Invocation_Edge_Count : Natural; + Cycle_Path : LGE_Lists.Doubly_Linked_List; + Indent : Indentation_Level) + is + Cycle : Library_Graph_Cycle_Id; + Path : LGE_Lists.Doubly_Linked_List; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Most_Significant_Edge)); + pragma Assert (LGE_Lists.Present (Cycle_Path)); + + -- Replicate the path of the cycle in order to avoid sharing lists + + Path := Copy_Cycle_Path (Cycle_Path); + + -- Normalize the path of the cycle such that its most significant + -- edge is the first in the list of edges. + + Normalize_Cycle_Path + (Cycle_Path => Path, + Most_Significant_Edge => Most_Significant_Edge); + + -- Save the cycle for diagnostic purposes. Its kind is determined by + -- its most significant edge. + + Cycle := Sequence_Next_Cycle; + + Set_LGC_Attributes + (G => G, + Cycle => Cycle, + Val => + (Invocation_Edge_Count => Invocation_Edge_Count, + Kind => + Cycle_Kind_Of + (G => G, + Edge => Most_Significant_Edge), + Path => Path)); + + Trace_Cycle (G, Cycle, Indent); + + -- Order the cycle based on its precedence relative to previously + -- discovered cycles. + + Order_Cycle (G, Cycle); + end Record_Cycle; + + ----------------------------------------- + -- Same_Library_Graph_Cycle_Attributes -- + ----------------------------------------- + + function Same_Library_Graph_Cycle_Attributes + (Left : Library_Graph_Cycle_Attributes; + Right : Library_Graph_Cycle_Attributes) return Boolean + is + begin + -- Two cycles are the same when + -- + -- * They are of the same kind + -- * They have the same number of invocation edges in their paths + -- * Their paths are the same length + -- * The edges comprising their paths are the same + + return + Left.Invocation_Edge_Count = Right.Invocation_Edge_Count + and then Left.Kind = Right.Kind + and then LGE_Lists.Equal (Left.Path, Right.Path); + end Same_Library_Graph_Cycle_Attributes; + ------------------------------ -- Set_Component_Attributes -- ------------------------------ @@ -2581,7 +5110,7 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (Comp)); - CA.Put (G.Component_Attributes, Comp, Val); + Component_Tables.Put (G.Component_Attributes, Comp, Val); end Set_Component_Attributes; ---------------------------- @@ -2590,18 +5119,18 @@ package body Bindo.Graphs is procedure Set_Corresponding_Item (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Val : Library_Graph_Vertex_Id) is Attrs : Library_Graph_Vertex_Attributes; begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - Attrs := Get_LGV_Attributes (G, LGV_Id); + Attrs := Get_LGV_Attributes (G, Vertex); Attrs.Corresponding_Item := Val; - Set_LGV_Attributes (G, LGV_Id, Attrs); + Set_LGV_Attributes (G, Vertex, Attrs); end Set_Corresponding_Item; ------------------------------ @@ -2617,7 +5146,7 @@ package body Bindo.Graphs is pragma Assert (Present (G)); pragma Assert (Present (U_Id)); - UV.Put (G.Unit_To_Vertex, U_Id, Val); + Unit_Tables.Put (G.Unit_To_Vertex, U_Id, Val); end Set_Corresponding_Vertex; ------------------------------ @@ -2626,25 +5155,25 @@ package body Bindo.Graphs is procedure Set_In_Elaboration_Order (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Val : Boolean := True) is Attrs : Library_Graph_Vertex_Attributes; begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - Attrs := Get_LGV_Attributes (G, LGV_Id); + Attrs := Get_LGV_Attributes (G, Vertex); Attrs.In_Elaboration_Order := Val; - Set_LGV_Attributes (G, LGV_Id, Attrs); + Set_LGV_Attributes (G, Vertex, Attrs); end Set_In_Elaboration_Order; - ---------------------------------------------------- - -- Set_Is_Existing_Predecessor_Successor_Relation -- - ---------------------------------------------------- + -------------------------- + -- Set_Is_Recorded_Edge -- + -------------------------- - procedure Set_Is_Existing_Predecessor_Successor_Relation + procedure Set_Is_Recorded_Edge (G : Library_Graph; Rel : Predecessor_Successor_Relation; Val : Boolean := True) @@ -2655,11 +5184,27 @@ package body Bindo.Graphs is pragma Assert (Present (Rel.Successor)); if Val then - PS.Insert (G.Relations, Rel); + RE_Sets.Insert (G.Recorded_Edges, Rel); else - PS.Delete (G.Relations, Rel); + RE_Sets.Delete (G.Recorded_Edges, Rel); end if; - end Set_Is_Existing_Predecessor_Successor_Relation; + end Set_Is_Recorded_Edge; + + ------------------------ + -- Set_LGC_Attributes -- + ------------------------ + + procedure Set_LGC_Attributes + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Val : Library_Graph_Cycle_Attributes) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + LGC_Tables.Put (G.Cycle_Attributes, Cycle, Val); + end Set_LGC_Attributes; ------------------------ -- Set_LGE_Attributes -- @@ -2667,14 +5212,14 @@ package body Bindo.Graphs is procedure Set_LGE_Attributes (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id; + Edge : Library_Graph_Edge_Id; Val : Library_Graph_Edge_Attributes) is begin pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Edge)); - EA.Put (G.Edge_Attributes, LGE_Id, Val); + LGE_Tables.Put (G.Edge_Attributes, Edge, Val); end Set_LGE_Attributes; ------------------------ @@ -2683,14 +5228,14 @@ package body Bindo.Graphs is procedure Set_LGV_Attributes (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Val : Library_Graph_Vertex_Attributes) is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - VA.Put (G.Vertex_Attributes, LGV_Id, Val); + LGV_Tables.Put (G.Vertex_Attributes, Vertex, Val); end Set_LGV_Attributes; --------------- @@ -2698,31 +5243,253 @@ package body Bindo.Graphs is --------------- function Successor - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Edge)); - return DG.Destination_Vertex (G.Graph, LGE_Id); + return DG.Destination_Vertex (G.Graph, Edge); end Successor; + --------------------- + -- Trace_Component -- + --------------------- + + procedure Trace_Component + (G : Library_Graph; + Comp : Component_Id; + Indent : Indentation_Level) + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Comp)); + + -- Nothing to do when switch -d_t (output cycle-detection trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_T then + return; + end if; + + Write_Eol; + Indent_By (Indent); + Write_Str ("component (Comp_"); + Write_Int (Int (Comp)); + Write_Str (")"); + Write_Eol; + end Trace_Component; + + ----------------- + -- Trace_Cycle -- + ----------------- + + procedure Trace_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id; + Indent : Indentation_Level) + is + Attr_Indent : constant Indentation_Level := + Indent + Nested_Indentation; + Edge_Indent : constant Indentation_Level := + Attr_Indent + Nested_Indentation; + + Edge : Library_Graph_Edge_Id; + Iter : Edges_Of_Cycle_Iterator; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + -- Nothing to do when switch -d_t (output cycle-detection trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_T then + return; + end if; + + Indent_By (Indent); + Write_Str ("cycle (LGC_Id_"); + Write_Int (Int (Cycle)); + Write_Str (")"); + Write_Eol; + + Indent_By (Attr_Indent); + Write_Str ("kind = "); + Write_Str (Kind (G, Cycle)'Img); + Write_Eol; + + Indent_By (Attr_Indent); + Write_Str ("invocation edges = "); + Write_Int (Int (Invocation_Edge_Count (G, Cycle))); + Write_Eol; + + Indent_By (Attr_Indent); + Write_Str ("length: "); + Write_Int (Int (Length (G, Cycle))); + Write_Eol; + + Iter := Iterate_Edges_Of_Cycle (G, Cycle); + while Has_Next (Iter) loop + Next (Iter, Edge); + + Indent_By (Edge_Indent); + Write_Str ("library graph edge (LGE_Id_"); + Write_Int (Int (Edge)); + Write_Str (")"); + Write_Eol; + end loop; + end Trace_Cycle; + + ---------------- + -- Trace_Edge -- + ---------------- + + procedure Trace_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id; + Indent : Indentation_Level) + is + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + Attr_Indent : constant Indentation_Level := + Indent + Nested_Indentation; + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, Edge); + Succ : constant Library_Graph_Vertex_Id := Successor (G, Edge); + + begin + -- Nothing to do when switch -d_t (output cycle-detection trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_T then + return; + end if; + + Indent_By (Indent); + Write_Str ("library graph edge (LGE_Id_"); + Write_Int (Int (Edge)); + Write_Str (")"); + Write_Eol; + + Indent_By (Attr_Indent); + Write_Str ("kind = "); + Write_Str (Kind (G, Edge)'Img); + Write_Eol; + + Indent_By (Attr_Indent); + Write_Str ("Predecessor (LGV_Id_"); + Write_Int (Int (Pred)); + Write_Str (") name = "); + Write_Name (Name (G, Pred)); + Write_Eol; + + Indent_By (Attr_Indent); + Write_Str ("Successor (LGV_Id_"); + Write_Int (Int (Succ)); + Write_Str (") name = "); + Write_Name (Name (G, Succ)); + Write_Eol; + end Trace_Edge; + + ------------------ + -- Trace_Vertex -- + ------------------ + + procedure Trace_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Indent : Indentation_Level) + is + Attr_Indent : constant Indentation_Level := + Indent + Nested_Indentation; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + -- Nothing to do when switch -d_t (output cycle-detection trace + -- information) is not in effect. + + if not Debug_Flag_Underscore_T then + return; + end if; + + Indent_By (Indent); + Write_Str ("library graph vertex (LGV_Id_"); + Write_Int (Int (Vertex)); + Write_Str (")"); + Write_Eol; + + Indent_By (Attr_Indent); + Write_Str ("Unit (U_Id_"); + Write_Int (Int (Unit (G, Vertex))); + Write_Str (") name = "); + Write_Name (Name (G, Vertex)); + Write_Eol; + end Trace_Vertex; + ---------- -- Unit -- ---------- function Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Unit_Id + Vertex : Library_Graph_Vertex_Id) return Unit_Id is begin pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); - return Get_LGV_Attributes (G, LGV_Id).Unit; + return Get_LGV_Attributes (G, Vertex).Unit; end Unit; + ------------- + -- Unvisit -- + ------------- + + procedure Unvisit + (Vertex : Library_Graph_Vertex_Id; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List) + is + Current_Vertex : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (Vertex)); + pragma Assert (LGV_Sets.Present (Visited_Set)); + pragma Assert (LGV_Lists.Present (Visited_Stack)); + + while not LGV_Lists.Is_Empty (Visited_Stack) loop + Current_Vertex := LGV_Lists.First (Visited_Stack); + + LGV_Lists.Delete_First (Visited_Stack); + LGV_Sets.Delete (Visited_Set, Current_Vertex); + + exit when Current_Vertex = Vertex; + end loop; + end Unvisit; + + --------------------------------- + -- Update_Pending_Predecessors -- + --------------------------------- + + procedure Update_Pending_Predecessors + (Strong_Predecessors : in out Natural; + Weak_Predecessors : in out Natural; + Update_Weak : Boolean; + Value : Integer) + is + begin + if Update_Weak then + Weak_Predecessors := Weak_Predecessors + Value; + else + Strong_Predecessors := Strong_Predecessors + Value; + end if; + end Update_Pending_Predecessors; + ----------------------------------------------- -- Update_Pending_Predecessors_Of_Components -- ----------------------------------------------- @@ -2730,18 +5497,17 @@ package body Bindo.Graphs is procedure Update_Pending_Predecessors_Of_Components (G : Library_Graph) is - Iter : All_Edge_Iterator; - LGE_Id : Library_Graph_Edge_Id; + Edge : Library_Graph_Edge_Id; + Iter : All_Edge_Iterator; begin pragma Assert (Present (G)); Iter := Iterate_All_Edges (G); while Has_Next (Iter) loop - Next (Iter, LGE_Id); - pragma Assert (Present (LGE_Id)); + Next (Iter, Edge); - Update_Pending_Predecessors_Of_Components (G, LGE_Id); + Update_Pending_Predecessors_Of_Components (G, Edge); end loop; end Update_Pending_Predecessors_Of_Components; @@ -2750,20 +5516,16 @@ package body Bindo.Graphs is ----------------------------------------------- procedure Update_Pending_Predecessors_Of_Components - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) is pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); + pragma Assert (Present (Edge)); - Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); - Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); - - pragma Assert (Present (Pred)); - pragma Assert (Present (Succ)); - - Pred_Comp : constant Component_Id := Component (G, Pred); - Succ_Comp : constant Component_Id := Component (G, Succ); + Pred_Comp : constant Component_Id := + Component (G, Predecessor (G, Edge)); + Succ_Comp : constant Component_Id := + Component (G, Successor (G, Edge)); pragma Assert (Present (Pred_Comp)); pragma Assert (Present (Succ_Comp)); @@ -2774,113 +5536,179 @@ package body Bindo.Graphs is -- must wait on another predecessor until it can be elaborated. if Pred_Comp /= Succ_Comp then - Increment_Pending_Predecessors (G, Succ_Comp); + Increment_Pending_Predecessors + (G => G, + Comp => Succ_Comp, + Edge => Edge); end if; end Update_Pending_Predecessors_Of_Components; + + ----------------------- + -- Vertex_Precedence -- + ----------------------- + + function Vertex_Precedence + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Compared_To : Library_Graph_Vertex_Id) return Precedence_Kind + is + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + pragma Assert (Present (Compared_To)); + + -- Use lexicographical order to determine precedence and ensure + -- deterministic behavior. + + if Uname_Less (Name (G, Vertex), Name (G, Compared_To)) then + return Higher_Precedence; + else + return Lower_Precedence; + end if; + end Vertex_Precedence; + + ----------- + -- Visit -- + ----------- + + procedure Visit + (Vertex : Library_Graph_Vertex_Id; + Visited_Set : LGV_Sets.Membership_Set; + Visited_Stack : LGV_Lists.Doubly_Linked_List) + is + begin + pragma Assert (Present (Vertex)); + pragma Assert (LGV_Sets.Present (Visited_Set)); + pragma Assert (LGV_Lists.Present (Visited_Stack)); + + LGV_Sets.Insert (Visited_Set, Vertex); + LGV_Lists.Prepend (Visited_Stack, Vertex); + end Visit; end Library_Graphs; ------------- -- Present -- ------------- - function Present (IGE_Id : Invocation_Graph_Edge_Id) return Boolean is + function Present (Edge : Invocation_Graph_Edge_Id) return Boolean is begin - return IGE_Id /= No_Invocation_Graph_Edge; + return Edge /= No_Invocation_Graph_Edge; end Present; ------------- -- Present -- ------------- - function Present (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean is + function Present (Vertex : Invocation_Graph_Vertex_Id) return Boolean is begin - return IGV_Id /= No_Invocation_Graph_Vertex; + return Vertex /= No_Invocation_Graph_Vertex; end Present; ------------- -- Present -- ------------- - function Present (LGE_Id : Library_Graph_Edge_Id) return Boolean is + function Present (Cycle : Library_Graph_Cycle_Id) return Boolean is begin - return LGE_Id /= No_Library_Graph_Edge; + return Cycle /= No_Library_Graph_Cycle; end Present; ------------- -- Present -- ------------- - function Present (LGV_Id : Library_Graph_Vertex_Id) return Boolean is + function Present (Edge : Library_Graph_Edge_Id) return Boolean is begin - return LGV_Id /= No_Library_Graph_Vertex; + return Edge /= No_Library_Graph_Edge; + end Present; + + ------------- + -- Present -- + ------------- + + function Present (Vertex : Library_Graph_Vertex_Id) return Boolean is + begin + return Vertex /= No_Library_Graph_Vertex; end Present; -------------------------- - -- Sequence_Next_IGE_Id -- + -- Sequence_Next_Edge -- -------------------------- IGE_Sequencer : Invocation_Graph_Edge_Id := First_Invocation_Graph_Edge; -- The counter for invocation graph edges. Do not directly manipulate its -- value. - function Sequence_Next_IGE_Id return Invocation_Graph_Edge_Id is - IGE_Id : constant Invocation_Graph_Edge_Id := IGE_Sequencer; + function Sequence_Next_Edge return Invocation_Graph_Edge_Id is + Edge : constant Invocation_Graph_Edge_Id := IGE_Sequencer; begin IGE_Sequencer := IGE_Sequencer + 1; - return IGE_Id; - end Sequence_Next_IGE_Id; + return Edge; + end Sequence_Next_Edge; -------------------------- - -- Sequence_Next_IGV_Id -- + -- Sequence_Next_Vertex -- -------------------------- IGV_Sequencer : Invocation_Graph_Vertex_Id := First_Invocation_Graph_Vertex; -- The counter for invocation graph vertices. Do not directly manipulate -- its value. + function Sequence_Next_Vertex return Invocation_Graph_Vertex_Id is + Vertex : constant Invocation_Graph_Vertex_Id := IGV_Sequencer; + + begin + IGV_Sequencer := IGV_Sequencer + 1; + return Vertex; + end Sequence_Next_Vertex; + -------------------------- - -- Sequence_Next_IGV_Id -- + -- Sequence_Next_Cycle -- -------------------------- - function Sequence_Next_IGV_Id return Invocation_Graph_Vertex_Id is - IGV_Id : constant Invocation_Graph_Vertex_Id := IGV_Sequencer; + LGC_Sequencer : Library_Graph_Cycle_Id := First_Library_Graph_Cycle; + -- The counter for library graph cycles. Do not directly manipulate its + -- value. + + function Sequence_Next_Cycle return Library_Graph_Cycle_Id is + Cycle : constant Library_Graph_Cycle_Id := LGC_Sequencer; begin - IGV_Sequencer := IGV_Sequencer + 1; - return IGV_Id; - end Sequence_Next_IGV_Id; + LGC_Sequencer := LGC_Sequencer + 1; + return Cycle; + end Sequence_Next_Cycle; -------------------------- - -- Sequence_Next_LGE_Id -- + -- Sequence_Next_Edge -- -------------------------- LGE_Sequencer : Library_Graph_Edge_Id := First_Library_Graph_Edge; -- The counter for library graph edges. Do not directly manipulate its -- value. - function Sequence_Next_LGE_Id return Library_Graph_Edge_Id is - LGE_Id : constant Library_Graph_Edge_Id := LGE_Sequencer; + function Sequence_Next_Edge return Library_Graph_Edge_Id is + Edge : constant Library_Graph_Edge_Id := LGE_Sequencer; begin LGE_Sequencer := LGE_Sequencer + 1; - return LGE_Id; - end Sequence_Next_LGE_Id; + return Edge; + end Sequence_Next_Edge; -------------------------- - -- Sequence_Next_LGV_Id -- + -- Sequence_Next_Vertex -- -------------------------- LGV_Sequencer : Library_Graph_Vertex_Id := First_Library_Graph_Vertex; -- The counter for library graph vertices. Do not directly manipulate its -- value. - function Sequence_Next_LGV_Id return Library_Graph_Vertex_Id is - LGV_Id : constant Library_Graph_Vertex_Id := LGV_Sequencer; + function Sequence_Next_Vertex return Library_Graph_Vertex_Id is + Vertex : constant Library_Graph_Vertex_Id := LGV_Sequencer; begin LGV_Sequencer := LGV_Sequencer + 1; - return LGV_Id; - end Sequence_Next_LGV_Id; + return Vertex; + end Sequence_Next_Vertex; end Bindo.Graphs; diff --git a/gcc/ada/bindo-graphs.ads b/gcc/ada/bindo-graphs.ads index a5dc6ea..f376801 100644 --- a/gcc/ada/bindo-graphs.ads +++ b/gcc/ada/bindo-graphs.ads @@ -28,11 +28,14 @@ -- The following unit defines the various graphs used in determining the -- elaboration order of units. +with Types; use Types; + with Bindo.Units; use Bindo.Units; with GNAT; use GNAT; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; with GNAT.Graphs; use GNAT.Graphs; +with GNAT.Lists; use GNAT.Lists; with GNAT.Sets; use GNAT.Sets; package Bindo.Graphs is @@ -49,14 +52,24 @@ package Bindo.Graphs is First_Invocation_Graph_Edge : constant Invocation_Graph_Edge_Id := No_Invocation_Graph_Edge + 1; + procedure Destroy_Invocation_Graph_Edge + (Edge : in out Invocation_Graph_Edge_Id); + pragma Inline (Destroy_Invocation_Graph_Edge); + -- Destroy invocation graph edge Edge + function Hash_Invocation_Graph_Edge - (IGE_Id : Invocation_Graph_Edge_Id) return Bucket_Range_Type; + (Edge : Invocation_Graph_Edge_Id) return Bucket_Range_Type; pragma Inline (Hash_Invocation_Graph_Edge); - -- Obtain the hash value of key IGE_Id + -- Obtain the hash value of key Edge - function Present (IGE_Id : Invocation_Graph_Edge_Id) return Boolean; + function Present (Edge : Invocation_Graph_Edge_Id) return Boolean; pragma Inline (Present); - -- Determine whether invocation graph edge IGE_Id exists + -- Determine whether invocation graph edge Edge exists + + package IGE_Lists is new Doubly_Linked_Lists + (Element_Type => Invocation_Graph_Edge_Id, + "=" => "=", + Destroy_Element => Destroy_Invocation_Graph_Edge); ------------------------------ -- Invocation graph vertex -- @@ -71,13 +84,47 @@ package Bindo.Graphs is No_Invocation_Graph_Vertex + 1; function Hash_Invocation_Graph_Vertex - (IGV_Id : Invocation_Graph_Vertex_Id) return Bucket_Range_Type; + (Vertex : Invocation_Graph_Vertex_Id) return Bucket_Range_Type; pragma Inline (Hash_Invocation_Graph_Vertex); - -- Obtain the hash value of key IGV_Id + -- Obtain the hash value of key Vertex - function Present (IGV_Id : Invocation_Graph_Vertex_Id) return Boolean; + function Present (Vertex : Invocation_Graph_Vertex_Id) return Boolean; pragma Inline (Present); - -- Determine whether invocation graph vertex IGV_Id exists + -- Determine whether invocation graph vertex Vertex exists + + package IGV_Sets is new Membership_Sets + (Element_Type => Invocation_Graph_Vertex_Id, + "=" => "=", + Hash => Hash_Invocation_Graph_Vertex); + + ------------------------- + -- Library graph cycle -- + ------------------------- + + type Library_Graph_Cycle_Id is new Natural; + No_Library_Graph_Cycle : constant Library_Graph_Cycle_Id := + Library_Graph_Cycle_Id'First; + First_Library_Graph_Cycle : constant Library_Graph_Cycle_Id := + No_Library_Graph_Cycle + 1; + + procedure Destroy_Library_Graph_Cycle + (Cycle : in out Library_Graph_Cycle_Id); + pragma Inline (Destroy_Library_Graph_Cycle); + -- Destroy library graph cycle Cycle + + function Hash_Library_Graph_Cycle + (Cycle : Library_Graph_Cycle_Id) return Bucket_Range_Type; + pragma Inline (Hash_Library_Graph_Cycle); + -- Obtain the hash value of key Cycle + + function Present (Cycle : Library_Graph_Cycle_Id) return Boolean; + pragma Inline (Present); + -- Determine whether library graph cycle Cycle exists + + package LGC_Lists is new Doubly_Linked_Lists + (Element_Type => Library_Graph_Cycle_Id, + "=" => "=", + Destroy_Element => Destroy_Library_Graph_Cycle); ------------------------ -- Library graph edge -- @@ -91,14 +138,29 @@ package Bindo.Graphs is First_Library_Graph_Edge : constant Library_Graph_Edge_Id := No_Library_Graph_Edge + 1; + procedure Destroy_Library_Graph_Edge + (Edge : in out Library_Graph_Edge_Id); + pragma Inline (Destroy_Library_Graph_Edge); + -- Destroy library graph edge Edge + function Hash_Library_Graph_Edge - (LGE_Id : Library_Graph_Edge_Id) return Bucket_Range_Type; + (Edge : Library_Graph_Edge_Id) return Bucket_Range_Type; pragma Inline (Hash_Library_Graph_Edge); - -- Obtain the hash value of key LGE_Id + -- Obtain the hash value of key Edge - function Present (LGE_Id : Library_Graph_Edge_Id) return Boolean; + function Present (Edge : Library_Graph_Edge_Id) return Boolean; pragma Inline (Present); - -- Determine whether library graph edge LGE_Id exists + -- Determine whether library graph edge Edge exists + + package LGE_Lists is new Doubly_Linked_Lists + (Element_Type => Library_Graph_Edge_Id, + "=" => "=", + Destroy_Element => Destroy_Library_Graph_Edge); + + package LGE_Sets is new Membership_Sets + (Element_Type => Library_Graph_Edge_Id, + "=" => "=", + Hash => Hash_Library_Graph_Edge); -------------------------- -- Library graph vertex -- @@ -112,14 +174,29 @@ package Bindo.Graphs is First_Library_Graph_Vertex : constant Library_Graph_Vertex_Id := No_Library_Graph_Vertex + 1; + procedure Destroy_Library_Graph_Vertex + (Vertex : in out Library_Graph_Vertex_Id); + pragma Inline (Destroy_Library_Graph_Vertex); + -- Destroy library graph vertex Vertex + function Hash_Library_Graph_Vertex - (LGV_Id : Library_Graph_Vertex_Id) return Bucket_Range_Type; + (Vertex : Library_Graph_Vertex_Id) return Bucket_Range_Type; pragma Inline (Hash_Library_Graph_Vertex); - -- Obtain the hash value of key LGV_Id + -- Obtain the hash value of key Vertex - function Present (LGV_Id : Library_Graph_Vertex_Id) return Boolean; + function Present (Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Present); - -- Determine whether library graph vertex LGV_Id exists + -- Determine whether library graph vertex Vertex exists + + package LGV_Lists is new Doubly_Linked_Lists + (Element_Type => Library_Graph_Vertex_Id, + "=" => "=", + Destroy_Element => Destroy_Library_Graph_Vertex); + + package LGV_Sets is new Membership_Sets + (Element_Type => Library_Graph_Vertex_Id, + "=" => "=", + Hash => Hash_Library_Graph_Vertex); ----------------------- -- Invocation_Graphs -- @@ -152,13 +229,16 @@ package Bindo.Graphs is -- describes. procedure Add_Vertex - (G : Invocation_Graph; - IC_Id : Invocation_Construct_Id; - LGV_Id : Library_Graph_Vertex_Id); + (G : Invocation_Graph; + IC_Id : Invocation_Construct_Id; + Body_Vertex : Library_Graph_Vertex_Id; + Spec_Vertex : Library_Graph_Vertex_Id); pragma Inline (Add_Vertex); -- Create a new vertex in invocation graph G. IC_Id is the invocation - -- construct the vertex describes. LGV_Id is the library graph vertex - -- where the invocation construct appears. + -- construct the vertex describes. Body_Vertex denotes the library graph + -- vertex where the invocation construct's body is declared. Spec_Vertex + -- is the library graph vertex where the invocation construct's spec is + -- declared. function Create (Initial_Vertices : Positive; @@ -179,11 +259,26 @@ package Bindo.Graphs is -- Vertex attributes -- ----------------------- + function Body_Vertex + (G : Invocation_Graph; + Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Body_Vertex); + -- Obtain the library graph vertex where the body of the invocation + -- construct represented by vertex Vertex of invocation graph G is + -- declared. + + function Column + (G : Invocation_Graph; + Vertex : Invocation_Graph_Vertex_Id) return Nat; + pragma Inline (Column); + -- Obtain the column number where the invocation construct vertex Vertex + -- of invocation graph G describes. + function Construct (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id; + Vertex : Invocation_Graph_Vertex_Id) return Invocation_Construct_Id; pragma Inline (Construct); - -- Obtain the invocation construct vertex IGV_Id of invocation graph G + -- Obtain the invocation construct vertex Vertex of invocation graph G -- describes. function Corresponding_Vertex @@ -193,41 +288,56 @@ package Bindo.Graphs is -- Obtain the vertex of invocation graph G that corresponds to signature -- IS_Id. - function Lib_Vertex + function Line (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id; - pragma Inline (Lib_Vertex); - -- Obtain the library graph vertex where vertex IGV_Id of invocation - -- graph appears. + Vertex : Invocation_Graph_Vertex_Id) return Nat; + pragma Inline (Line); + -- Obtain the line number where the invocation construct vertex Vertex + -- of invocation graph G describes. function Name (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Name_Id; + Vertex : Invocation_Graph_Vertex_Id) return Name_Id; pragma Inline (Name); - -- Obtain the name of the construct vertex IGV_Id of invocation graph G + -- Obtain the name of the construct vertex Vertex of invocation graph G -- describes. + function Spec_Vertex + (G : Invocation_Graph; + Vertex : Invocation_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + pragma Inline (Spec_Vertex); + -- Obtain the library graph vertex where the spec of the invocation + -- construct represented by vertex Vertex of invocation graph G is + -- declared. + --------------------- -- Edge attributes -- --------------------- + function Extra + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Name_Id; + pragma Inline (Extra); + -- Obtain the extra name used in error diagnostics of edge Edge of + -- invocation graph G. + function Kind - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Kind; + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Invocation_Kind; pragma Inline (Kind); - -- Obtain the nature of edge IGE_Id of invocation graph G + -- Obtain the nature of edge Edge of invocation graph G function Relation - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Relation_Id; + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Invocation_Relation_Id; pragma Inline (Relation); - -- Obtain the relation edge IGE_Id of invocation graph G describes + -- Obtain the relation edge Edge of invocation graph G describes function Target - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id; + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) return Invocation_Graph_Vertex_Id; pragma Inline (Target); - -- Obtain the target vertex edge IGE_Id of invocation graph G designates + -- Obtain the target vertex edge Edge of invocation graph G designates ---------------- -- Statistics -- @@ -245,9 +355,9 @@ package Bindo.Graphs is function Number_Of_Edges_To_Targets (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Natural; + Vertex : Invocation_Graph_Vertex_Id) return Natural; pragma Inline (Number_Of_Edges_To_Targets); - -- Obtain the total number of edges to targets vertex IGV_Id of + -- Obtain the total number of edges to targets vertex Vertex of -- invocation graph G has. function Number_Of_Elaboration_Roots @@ -278,8 +388,8 @@ package Bindo.Graphs is -- Obtain an iterator over all edges of invocation graph G procedure Next - (Iter : in out All_Edge_Iterator; - IGE_Id : out Invocation_Graph_Edge_Id); + (Iter : in out All_Edge_Iterator; + Edge : out Invocation_Graph_Edge_Id); pragma Inline (Next); -- Return the current edge referenced by iterator Iter and advance to -- the next available edge. @@ -300,7 +410,7 @@ package Bindo.Graphs is procedure Next (Iter : in out All_Vertex_Iterator; - IGV_Id : out Invocation_Graph_Vertex_Id); + Vertex : out Invocation_Graph_Vertex_Id); pragma Inline (Next); -- Return the current vertex referenced by iterator Iter and advance -- to the next available vertex. @@ -316,14 +426,14 @@ package Bindo.Graphs is function Iterate_Edges_To_Targets (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator; + Vertex : Invocation_Graph_Vertex_Id) return Edges_To_Targets_Iterator; pragma Inline (Iterate_Edges_To_Targets); -- Obtain an iterator over all edges to targets with source vertex - -- IGV_Id of invocation graph G. + -- Vertex of invocation graph G. procedure Next - (Iter : in out Edges_To_Targets_Iterator; - IGE_Id : out Invocation_Graph_Edge_Id); + (Iter : in out Edges_To_Targets_Iterator; + Edge : out Invocation_Graph_Edge_Id); pragma Inline (Next); -- Return the current edge referenced by iterator Iter and advance to -- the next available edge. @@ -357,32 +467,38 @@ package Bindo.Graphs is -------------- procedure Destroy_Invocation_Graph_Vertex - (IGV_Id : in out Invocation_Graph_Vertex_Id); + (Vertex : in out Invocation_Graph_Vertex_Id); pragma Inline (Destroy_Invocation_Graph_Vertex); - -- Destroy invocation graph vertex IGV_Id + -- Destroy invocation graph vertex Vertex -- The following type represents the attributes of an invocation graph -- vertex. type Invocation_Graph_Vertex_Attributes is record + Body_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- Reference to the library graph vertex where the body of this + -- vertex resides. + Construct : Invocation_Construct_Id := No_Invocation_Construct; -- Reference to the invocation construct this vertex represents - Lib_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; - -- Reference to the library graph vertex where this vertex resides + Spec_Vertex : Library_Graph_Vertex_Id := No_Library_Graph_Vertex; + -- Reference to the library graph vertex where the spec of this + -- vertex resides. end record; No_Invocation_Graph_Vertex_Attributes : constant Invocation_Graph_Vertex_Attributes := - (Construct => No_Invocation_Construct, - Lib_Vertex => No_Library_Graph_Vertex); + (Body_Vertex => No_Library_Graph_Vertex, + Construct => No_Invocation_Construct, + Spec_Vertex => No_Library_Graph_Vertex); procedure Destroy_Invocation_Graph_Vertex_Attributes (Attrs : in out Invocation_Graph_Vertex_Attributes); pragma Inline (Destroy_Invocation_Graph_Vertex_Attributes); -- Destroy the contents of attributes Attrs - package VA is new Dynamic_Hash_Tables + package IGV_Tables is new Dynamic_Hash_Tables (Key_Type => Invocation_Graph_Vertex_Id, Value_Type => Invocation_Graph_Vertex_Attributes, No_Value => No_Invocation_Graph_Vertex_Attributes, @@ -399,9 +515,9 @@ package Bindo.Graphs is ----------- procedure Destroy_Invocation_Graph_Edge - (IGE_Id : in out Invocation_Graph_Edge_Id); + (Edge : in out Invocation_Graph_Edge_Id); pragma Inline (Destroy_Invocation_Graph_Edge); - -- Destroy invocation graph edge IGE_Id + -- Destroy invocation graph edge Edge -- The following type represents the attributes of an invocation graph -- edge. @@ -420,7 +536,7 @@ package Bindo.Graphs is pragma Inline (Destroy_Invocation_Graph_Edge_Attributes); -- Destroy the contents of attributes Attrs - package EA is new Dynamic_Hash_Tables + package IGE_Tables is new Dynamic_Hash_Tables (Key_Type => Invocation_Graph_Edge_Id, Value_Type => Invocation_Graph_Edge_Attributes, No_Value => No_Invocation_Graph_Edge_Attributes, @@ -457,7 +573,7 @@ package Bindo.Graphs is pragma Inline (Hash_Source_Target_Relation); -- Obtain the hash value of key Rel - package ST is new Membership_Sets + package Relation_Sets is new Membership_Sets (Element_Type => Source_Target_Relation, "=" => "=", Hash => Hash_Source_Target_Relation); @@ -477,7 +593,7 @@ package Bindo.Graphs is pragma Inline (Hash_Invocation_Signature); -- Obtain the hash value of key IS_Id - package SV is new Dynamic_Hash_Tables + package Signature_Tables is new Dynamic_Hash_Tables (Key_Type => Invocation_Signature_Id, Value_Type => Invocation_Graph_Vertex_Id, No_Value => No_Invocation_Graph_Vertex, @@ -493,7 +609,7 @@ package Bindo.Graphs is -- Elaboration roots -- ----------------------- - package ER is new Membership_Sets + package IGV_Sets is new Membership_Sets (Element_Type => Invocation_Graph_Vertex_Id, "=" => "=", Hash => Hash_Invocation_Graph_Vertex); @@ -518,24 +634,25 @@ package Bindo.Graphs is Counts : Invocation_Graph_Edge_Counts := (others => 0); -- Edge statistics - Edge_Attributes : EA.Dynamic_Hash_Table := EA.Nil; + Edge_Attributes : IGE_Tables.Dynamic_Hash_Table := IGE_Tables.Nil; -- The map of edge -> edge attributes for all edges in the graph Graph : DG.Directed_Graph := DG.Nil; -- The underlying graph describing the relations between edges and -- vertices. - Relations : ST.Membership_Set := ST.Nil; + Relations : Relation_Sets.Membership_Set := Relation_Sets.Nil; -- The set of relations between source and targets, used to prevent -- duplicate edges in the graph. - Roots : ER.Membership_Set := ER.Nil; + Roots : IGV_Sets.Membership_Set := IGV_Sets.Nil; -- The set of elaboration root vertices - Signature_To_Vertex : SV.Dynamic_Hash_Table := SV.Nil; + Signature_To_Vertex : Signature_Tables.Dynamic_Hash_Table := + Signature_Tables.Nil; -- The map of signature -> vertex - Vertex_Attributes : VA.Dynamic_Hash_Table := VA.Nil; + Vertex_Attributes : IGV_Tables.Dynamic_Hash_Table := IGV_Tables.Nil; -- The map of vertex -> vertex attributes for all vertices in the -- graph. end record; @@ -550,7 +667,7 @@ package Bindo.Graphs is type All_Edge_Iterator is new DG.All_Edge_Iterator; type All_Vertex_Iterator is new DG.All_Vertex_Iterator; type Edges_To_Targets_Iterator is new DG.Outgoing_Edge_Iterator; - type Elaboration_Root_Iterator is new ER.Iterator; + type Elaboration_Root_Iterator is new IGV_Sets.Iterator; end Invocation_Graphs; -------------------- @@ -559,6 +676,32 @@ package Bindo.Graphs is package Library_Graphs is + -- The following type represents the various kinds of library graph + -- cycles. The ordering of kinds is significant, where a literal with + -- lower ordinal has a higher precedence than one with higher ordinal. + + type Library_Graph_Cycle_Kind is + (Elaborate_Body_Cycle, + -- A cycle that involves at least one spec-body pair, where the + -- spec is subject to pragma Elaborate_Body. This is the highest + -- precedence cycle. + + Elaborate_Cycle, + -- A cycle that involves at least one Elaborate edge + + Elaborate_All_Cycle, + -- A cycle that involves at least one Elaborate_All edge + + Forced_Cycle, + -- A cycle that involves at least one edge which is a byproduct of + -- the forced-elaboration-order file. + + Invocation_Cycle, + -- A cycle that involves at least one invocation edge. This is the + -- lowest precedence cycle. + + No_Cycle_Kind); + -- The following type represents the various kinds of library edges type Library_Graph_Edge_Kind is @@ -599,18 +742,33 @@ package Bindo.Graphs is type Library_Graph is private; Nil : constant Library_Graph; + type LGE_Predicate_Ptr is access function + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + + type LGV_Comparator_Ptr is access function + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Compared_To : Library_Graph_Vertex_Id) return Precedence_Kind; + + type LGV_Predicate_Ptr is access function + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + ---------------------- -- Graph operations -- ---------------------- procedure Add_Edge - (G : Library_Graph; - Pred : Library_Graph_Vertex_Id; - Succ : Library_Graph_Vertex_Id; - Kind : Library_Graph_Edge_Kind); + (G : Library_Graph; + Pred : Library_Graph_Vertex_Id; + Succ : Library_Graph_Vertex_Id; + Kind : Library_Graph_Edge_Kind; + Activates_Task : Boolean); pragma Inline (Add_Edge); -- Create a new edge in library graph G with source vertex Pred and - -- destination vertex Succ. Kind denotes the nature of the edge. + -- destination vertex Succ. Kind denotes the nature of the edge. Flag + -- Activates_Task should be set when the edge involves task activation. procedure Add_Vertex (G : Library_Graph; @@ -634,6 +792,16 @@ package Bindo.Graphs is pragma Inline (Find_Components); -- Find all components in library graph G + procedure Find_Cycles (G : Library_Graph); + pragma Inline (Find_Cycles); + -- Find all cycles in library graph G + + function Highest_Precedence_Cycle + (G : Library_Graph) return Library_Graph_Cycle_Id; + pragma Inline (Highest_Precedence_Cycle); + -- Obtain the cycle with highest precedence among all other cycles of + -- library graph G. + function Present (G : Library_Graph) return Boolean; pragma Inline (Present); -- Determine whether library graph G exists @@ -644,16 +812,16 @@ package Bindo.Graphs is function Component (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Component_Id; + Vertex : Library_Graph_Vertex_Id) return Component_Id; pragma Inline (Component); - -- Obtain the component where vertex LGV_Id of library graph G resides + -- Obtain the component where vertex Vertex of library graph G resides function Corresponding_Item (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; pragma Inline (Corresponding_Item); -- Obtain the complementary vertex which represents the corresponding - -- spec or body of vertex LGV_Id of library graph G. + -- spec or body of vertex Vertex of library graph G. function Corresponding_Vertex (G : Library_Graph; @@ -664,75 +832,117 @@ package Bindo.Graphs is procedure Decrement_Pending_Predecessors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id); + Vertex : Library_Graph_Vertex_Id; + Edge : Library_Graph_Edge_Id); pragma Inline (Decrement_Pending_Predecessors); - -- Decrease the number of pending predecessors vertex LGV_Id of library - -- graph G must wait on until it can be elaborated. + -- Decrease the number of pending predecessors vertex Vertex which was + -- reached via edge Edge of library graph G must wait until it can be + -- elaborated. + + function File_Name + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return File_Name_Type; + pragma Inline (File_Name); + -- Obtain the name of the file where vertex Vertex of library graph G + -- resides. function In_Elaboration_Order (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (In_Elaboration_Order); - -- Determine whether vertex LGV_Id of library graph G is already in some + -- Determine whether vertex Vertex of library graph G is already in some -- elaboration order. + function Invocation_Graph_Encoding + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) + return Invocation_Graph_Encoding_Kind; + pragma Inline (Invocation_Graph_Encoding); + -- Obtain the encoding format used to capture information related to + -- invocation vertices and edges that reside within vertex Vertex of + -- library graph G. + function Name (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Unit_Name_Type; + Vertex : Library_Graph_Vertex_Id) return Unit_Name_Type; pragma Inline (Name); - -- Obtain the name of the unit which vertex LGV_Id of library graph G + -- Obtain the name of the unit which vertex Vertex of library graph G -- represents. - function Pending_Predecessors + procedure Pending_Predecessors_For_Elaboration + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Strong_Preds : out Natural; + Weak_Preds : out Natural); + pragma Inline (Pending_Predecessors_For_Elaboration); + -- Obtain the number of pending strong and weak predecessors of vertex + -- Vertex of library graph G, taking into account Elaborate_Body pairs. + -- Strong predecessors are returned in Strong_Preds. Weak predecessors + -- are returned in Weak_Preds. + + function Pending_Strong_Predecessors + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Natural; + pragma Inline (Pending_Strong_Predecessors); + -- Obtain the number of pending strong predecessors vertex Vertex of + -- library graph G must wait on until it can be elaborated. + + function Pending_Weak_Predecessors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Natural; - pragma Inline (Pending_Predecessors); - -- Obtain the number of pending predecessors vertex LGV_Id of library - -- graph G must wait on until it can be elaborated. + Vertex : Library_Graph_Vertex_Id) return Natural; + pragma Inline (Pending_Weak_Predecessors); + -- Obtain the number of pending weak predecessors vertex Vertex of + -- library graph G must wait on until it can be elaborated. procedure Set_Corresponding_Item (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Val : Library_Graph_Vertex_Id); pragma Inline (Set_Corresponding_Item); -- Set the complementary vertex which represents the corresponding - -- spec or body of vertex LGV_Id of library graph G to value Val. + -- spec or body of vertex Vertex of library graph G to value Val. procedure Set_In_Elaboration_Order (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; Val : Boolean := True); pragma Inline (Set_In_Elaboration_Order); - -- Mark vertex LGV_Id of library graph G as included in some elaboration + -- Mark vertex Vertex of library graph G as included in some elaboration -- order depending on value Val. function Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Unit_Id; + Vertex : Library_Graph_Vertex_Id) return Unit_Id; pragma Inline (Unit); - -- Obtain the unit vertex LGV_Id of library graph G represents + -- Obtain the unit vertex Vertex of library graph G represents --------------------- -- Edge attributes -- --------------------- + function Activates_Task + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Activates_Task); + -- Determine whether edge Edge of library graph G activates a task + function Kind - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind; + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Edge_Kind; pragma Inline (Kind); - -- Obtain the nature of edge LGE_Id of library graph G + -- Obtain the nature of edge Edge of library graph G function Predecessor - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; pragma Inline (Predecessor); - -- Obtain the predecessor vertex of edge LGE_Id of library graph G + -- Obtain the predecessor vertex of edge Edge of library graph G function Successor - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Library_Graph_Vertex_Id; pragma Inline (Successor); - -- Obtain the successor vertex of edge LGE_Id of library graph G + -- Obtain the successor vertex of edge Edge of library graph G -------------------------- -- Component attributes -- @@ -740,120 +950,276 @@ package Bindo.Graphs is procedure Decrement_Pending_Predecessors (G : Library_Graph; - Comp : Component_Id); + Comp : Component_Id; + Edge : Library_Graph_Edge_Id); pragma Inline (Decrement_Pending_Predecessors); - -- Decrease the number of pending predecessors component Comp of library - -- graph G must wait on until it can be elaborated. + -- Decrease the number of pending predecessors component Comp which was + -- reached via edge Edge of library graph G must wait on until it can be + -- elaborated. - function Pending_Predecessors + function Pending_Strong_Predecessors (G : Library_Graph; Comp : Component_Id) return Natural; - pragma Inline (Pending_Predecessors); - -- Obtain the number of pending predecessors component Comp of library - -- graph G must wait on until it can be elaborated. + pragma Inline (Pending_Strong_Predecessors); + -- Obtain the number of pending strong predecessors component Comp of + -- library graph G must wait on until it can be elaborated. + + function Pending_Weak_Predecessors + (G : Library_Graph; + Comp : Component_Id) return Natural; + pragma Inline (Pending_Weak_Predecessors); + -- Obtain the number of pending weak predecessors component Comp of + -- library graph G must wait on until it can be elaborated. + + ---------------------- + -- Cycle attributes -- + ---------------------- + + function Invocation_Edge_Count + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Natural; + pragma Inline (Invocation_Edge_Count); + -- Obtain the number of invocation edges in cycle Cycle of library + -- graph G. + + function Kind + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Library_Graph_Cycle_Kind; + pragma Inline (Kind); + -- Obtain the nature of cycle Cycle of library graph G + + function Length + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Natural; + pragma Inline (Length); + -- Obtain the length of cycle Cycle of library graph G --------------- -- Semantics -- --------------- + function Complementary_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id; + Force_Complement : Boolean) return Library_Graph_Vertex_Id; + pragma Inline (Complementary_Vertex); + -- Obtain the complementary vertex of vertex Vertex of library graph G + -- as follows: + -- + -- * If Vertex is the spec of an Elaborate_Body pair, return the body + -- * If Vertex is the body of an Elaborate_Body pair, return the spec + -- + -- This behavior can be forced by setting flag Force_Complement to True. + + function Contains_Elaborate_All_Edge + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Boolean; + pragma Inline (Contains_Elaborate_All_Edge); + -- Determine whether cycle Cycle of library graph G contains an + -- Elaborate_All edge. + + function Contains_Static_Successor_Edge + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Boolean; + pragma Inline (Contains_Static_Successor_Edge); + -- Determine whether cycle Cycle of library graph G contains an edge + -- where the successor was compiled using the static model. + + function Contains_Task_Activation + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Boolean; + pragma Inline (Contains_Task_Activation); + -- Determine whether cycle Cycle of library graph G contains an + -- invocation edge where the path it represents involves a task + -- activation. + + function Has_Elaborate_All_Cycle (G : Library_Graph) return Boolean; + pragma Inline (Has_Elaborate_All_Cycle); + -- Determine whether library graph G contains a cycle involving pragma + -- Elaborate_All. + + function Has_No_Elaboration_Code + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Has_No_Elaboration_Code); + -- Determine whether vertex Vertex of library graph G represents a unit + -- that lacks elaboration code. + + function In_Same_Component + (G : Library_Graph; + Left : Library_Graph_Vertex_Id; + Right : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (In_Same_Component); + -- Determine whether vertices Left and Right of library graph G reside + -- in the same component. + function Is_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Body); - -- Determine whether vertex LGV_Id of library graph G denotes a body + -- Determine whether vertex Vertex of library graph G denotes a body function Is_Body_Of_Spec_With_Elaborate_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Body_Of_Spec_With_Elaborate_Body); - -- Determine whether vertex LGV_Id of library graph G denotes a body + -- Determine whether vertex Vertex of library graph G denotes a body -- with a corresponding spec, and the spec has pragma Elaborate_Body. function Is_Body_With_Spec (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Body_With_Spec); - -- Determine whether vertex LGV_Id of library graph G denotes a body + -- Determine whether vertex Vertex of library graph G denotes a body -- with a corresponding spec. + function Is_Dynamically_Elaborated + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Dynamically_Elaborated); + -- Determine whether vertex Vertex of library graph G was compiled + -- using the dynamic model. + function Is_Elaborable_Component (G : Library_Graph; Comp : Component_Id) return Boolean; pragma Inline (Is_Elaborable_Component); - -- Determine whether component Comp of library graph G can be elaborated + -- Determine whether component Comp of library graph G is not waiting on + -- any predecessors, and can thus be elaborated. function Is_Elaborable_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Elaborable_Vertex); - -- Determine whether vertex LGV_Id of library graph G can be elaborated + -- Determine whether vertex Vertex of library graph G is not waiting on + -- any predecessors, and can thus be elaborated. + + function Is_Elaborate_All_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Elaborate_All_Edge); + -- Determine whether edge Edge of library graph G is an edge whose + -- predecessor is subject to pragma Elaborate_All. + + function Is_Elaborate_Body_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Elaborate_Body_Edge); + -- Determine whether edge Edge of library graph G has a successor + -- that is either a spec subject to pragma Elaborate_Body, or a body + -- that completes such a spec. + + function Is_Elaborate_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Elaborate_Edge); + -- Determine whether edge Edge of library graph G is an edge whose + -- predecessor is subject to pragma Elaborate. + + function Is_Elaborate_Body_Pair + (G : Library_Graph; + Spec_Vertex : Library_Graph_Vertex_Id; + Body_Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Elaborate_Body_Pair); + -- Determine whether vertices Spec_Vertex and Body_Vertex of library + -- graph G denote a spec subject to Elaborate_Body and its completing + -- body. + + function Is_Forced_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Forced_Edge); + -- Determine whether edge Edge of library graph G is a byproduct of the + -- forced-elaboration-order file. function Is_Internal_Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Internal_Unit); - -- Determine whether vertex LGV_Id of library graph G denotes an + -- Determine whether vertex Vertex of library graph G denotes an -- internal unit. + function Is_Invocation_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Invocation_Edge); + -- Determine whether edge Edge of library graph G came from the + -- traversal of the invocation graph. + function Is_Predefined_Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Predefined_Unit); - -- Determine whether vertex LGV_Id of library graph G denotes a + -- Determine whether vertex Vertex of library graph G denotes a -- predefined unit. function Is_Preelaborated_Unit (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Preelaborated_Unit); - -- Determine whether vertex LGV_Id of library graph G denotes a unit - -- subjec to pragma Pure or Preelaborable. + -- Determine whether vertex Vertex of library graph G denotes a unit + -- subject to pragma Pure or Preelaborable. function Is_Spec (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Spec); - -- Determine whether vertex LGV_Id of library graph G denotes a spec + -- Determine whether vertex Vertex of library graph G denotes a spec + + function Is_Spec_Before_Body_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_Spec_Before_Body_Edge); + -- Determine whether edge Edge of library graph G links a predecessor + -- spec and a successor body belonging to the same unit. function Is_Spec_With_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Spec_With_Body); - -- Determine whether vertex LGV_Id of library graph G denotes a spec + -- Determine whether vertex Vertex of library graph G denotes a spec -- with a corresponding body. function Is_Spec_With_Elaborate_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Is_Spec_With_Elaborate_Body); - -- Determine whether vertex LGV_Id of library graph G denotes a spec + -- Determine whether vertex Vertex of library graph G denotes a spec -- with a corresponding body, and is subject to pragma Elaborate_Body. - function Links_Vertices_In_Same_Component + function Is_Weakly_Elaborable_Vertex (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) return Boolean; - pragma Inline (Links_Vertices_In_Same_Component); - -- Determine whether edge LGE_Id of library graph G links a predecessor - -- and a successor that reside within the same component. + Vertex : Library_Graph_Vertex_Id) return Boolean; + pragma Inline (Is_Weakly_Elaborable_Vertex); + -- Determine whether vertex Vertex of library graph G is waiting on + -- weak predecessors only, in which case it can be elaborated assuming + -- that the weak edges will not be exercised at elaboration time. + + function Is_With_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) return Boolean; + pragma Inline (Is_With_Edge); + -- Determine whether edge Edge of library graph G is the result of a + -- with dependency between its successor and predecessor. function Needs_Elaboration (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Boolean; + Vertex : Library_Graph_Vertex_Id) return Boolean; pragma Inline (Needs_Elaboration); - -- Determine whether vertex LGV_Id of library graph G represents a unit + -- Determine whether vertex Vertex of library graph G represents a unit -- that needs to be elaborated. function Proper_Body (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; pragma Inline (Proper_Body); - -- Obtain the body of vertex LGV_Id of library graph G + -- Obtain the body of vertex Vertex of library graph G function Proper_Spec (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id) return Library_Graph_Vertex_Id; pragma Inline (Proper_Spec); - -- Obtain the spec of vertex LGV_Id of library graph G + -- Obtain the spec of vertex Vertex of library graph G ---------------- -- Statistics -- @@ -876,15 +1242,19 @@ package Bindo.Graphs is pragma Inline (Number_Of_Components); -- Obtain the total number of components in library graph G + function Number_Of_Cycles (G : Library_Graph) return Natural; + pragma Inline (Number_Of_Cycles); + -- Obtain the total number of cycles in library graph G + function Number_Of_Edges (G : Library_Graph) return Natural; pragma Inline (Number_Of_Edges); -- Obtain the total number of edges in library graph G function Number_Of_Edges_To_Successors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Natural; + Vertex : Library_Graph_Vertex_Id) return Natural; pragma Inline (Number_Of_Edges_To_Successors); - -- Obtain the total number of edges to successors vertex LGV_Id of + -- Obtain the total number of edges to successors vertex Vertex of -- library graph G has. function Number_Of_Vertices (G : Library_Graph) return Natural; @@ -895,6 +1265,27 @@ package Bindo.Graphs is -- Iterators -- --------------- + -- The following type represents an iterator over all cycles of a + -- library graph. + + type All_Cycle_Iterator is private; + + function Has_Next (Iter : All_Cycle_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more cycles to examine + + function Iterate_All_Cycles + (G : Library_Graph) return All_Cycle_Iterator; + pragma Inline (Iterate_All_Cycles); + -- Obtain an iterator over all cycles of library graph G + + procedure Next + (Iter : in out All_Cycle_Iterator; + Cycle : out Library_Graph_Cycle_Id); + pragma Inline (Next); + -- Return the current cycle referenced by iterator Iter and advance to + -- the next available cycle. + -- The following type represents an iterator over all edges of a library -- graph. @@ -909,8 +1300,8 @@ package Bindo.Graphs is -- Obtain an iterator over all edges of library graph G procedure Next - (Iter : in out All_Edge_Iterator; - LGE_Id : out Library_Graph_Edge_Id); + (Iter : in out All_Edge_Iterator; + Edge : out Library_Graph_Edge_Id); pragma Inline (Next); -- Return the current edge referenced by iterator Iter and advance to -- the next available edge. @@ -931,7 +1322,7 @@ package Bindo.Graphs is procedure Next (Iter : in out All_Vertex_Iterator; - LGV_Id : out Library_Graph_Vertex_Id); + Vertex : out Library_Graph_Vertex_Id); pragma Inline (Next); -- Return the current vertex referenced by iterator Iter and advance -- to the next available vertex. @@ -975,11 +1366,34 @@ package Bindo.Graphs is procedure Next (Iter : in out Component_Vertex_Iterator; - LGV_Id : out Library_Graph_Vertex_Id); + Vertex : out Library_Graph_Vertex_Id); pragma Inline (Next); -- Return the current vertex referenced by iterator Iter and advance -- to the next available vertex. + -- The following type represents an iterator over all edges that form a + -- cycle. + + type Edges_Of_Cycle_Iterator is private; + + function Has_Next (Iter : Edges_Of_Cycle_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more edges to examine + + function Iterate_Edges_Of_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) return Edges_Of_Cycle_Iterator; + pragma Inline (Iterate_Edges_Of_Cycle); + -- Obtain an iterator over all edges that form cycle Cycle of library + -- graph G. + + procedure Next + (Iter : in out Edges_Of_Cycle_Iterator; + Edge : out Library_Graph_Edge_Id); + pragma Inline (Next); + -- Return the current edge referenced by iterator Iter and advance to + -- the next available edge. + -- The following type represents an iterator over all edges that reach -- successors starting from a particular predecessor vertex. @@ -991,14 +1405,14 @@ package Bindo.Graphs is function Iterate_Edges_To_Successors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) return Edges_To_Successors_Iterator; + Vertex : Library_Graph_Vertex_Id) return Edges_To_Successors_Iterator; pragma Inline (Iterate_Components); -- Obtain an iterator over all edges to successors with predecessor - -- vertex LGV_Id of library graph G. + -- vertex Vertex of library graph G. procedure Next - (Iter : in out Edges_To_Successors_Iterator; - LGE_Id : out Library_Graph_Edge_Id); + (Iter : in out Edges_To_Successors_Iterator; + Edge : out Library_Graph_Edge_Id); pragma Inline (Next); -- Return the current edge referenced by iterator Iter and advance to -- the next available edge. @@ -1009,11 +1423,6 @@ package Bindo.Graphs is -- Vertices -- -------------- - procedure Destroy_Library_Graph_Vertex - (LGV_Id : in out Library_Graph_Vertex_Id); - pragma Inline (Destroy_Library_Graph_Vertex); - -- Destroy library graph vertex LGV_Id - -- The following type represents the attributes of a library graph -- vertex. @@ -1034,9 +1443,13 @@ package Bindo.Graphs is In_Elaboration_Order : Boolean := False; -- Set when this vertex is elaborated - Pending_Predecessors : Natural := 0; - -- The number of pending predecessor vertices this vertex must wait - -- on before it can be elaborated. + Pending_Strong_Predecessors : Natural := 0; + -- The number of pending strong predecessor vertices this vertex must + -- wait on before it can be elaborated. + + Pending_Weak_Predecessors : Natural := 0; + -- The number of weak predecessor vertices this vertex must wait on + -- before it can be elaborated. Unit : Unit_Id := No_Unit_Id; -- The reference to unit this vertex represents @@ -1044,17 +1457,18 @@ package Bindo.Graphs is No_Library_Graph_Vertex_Attributes : constant Library_Graph_Vertex_Attributes := - (Corresponding_Item => No_Library_Graph_Vertex, - In_Elaboration_Order => False, - Pending_Predecessors => 0, - Unit => No_Unit_Id); + (Corresponding_Item => No_Library_Graph_Vertex, + In_Elaboration_Order => False, + Pending_Strong_Predecessors => 0, + Pending_Weak_Predecessors => 0, + Unit => No_Unit_Id); procedure Destroy_Library_Graph_Vertex_Attributes (Attrs : in out Library_Graph_Vertex_Attributes); pragma Inline (Destroy_Library_Graph_Vertex_Attributes); -- Destroy the contents of attributes Attrs - package VA is new Dynamic_Hash_Tables + package LGV_Tables is new Dynamic_Hash_Tables (Key_Type => Library_Graph_Vertex_Id, Value_Type => Library_Graph_Vertex_Attributes, No_Value => No_Library_Graph_Vertex_Attributes, @@ -1070,28 +1484,28 @@ package Bindo.Graphs is -- Edges -- ----------- - procedure Destroy_Library_Graph_Edge - (LGE_Id : in out Library_Graph_Edge_Id); - pragma Inline (Destroy_Library_Graph_Edge); - -- Destroy library graph edge LGE_Id - -- The following type represents the attributes of a library graph edge type Library_Graph_Edge_Attributes is record + Activates_Task : Boolean := False; + -- Set for an invocation edge, where at least one of the paths the + -- edge represents activates a task. + Kind : Library_Graph_Edge_Kind := No_Edge; -- The nature of the library graph edge end record; No_Library_Graph_Edge_Attributes : constant Library_Graph_Edge_Attributes := - (Kind => No_Edge); + (Activates_Task => False, + Kind => No_Edge); procedure Destroy_Library_Graph_Edge_Attributes (Attrs : in out Library_Graph_Edge_Attributes); pragma Inline (Destroy_Library_Graph_Edge_Attributes); -- Destroy the contents of attributes Attrs - package EA is new Dynamic_Hash_Tables + package LGE_Tables is new Dynamic_Hash_Tables (Key_Type => Library_Graph_Edge_Id, Value_Type => Library_Graph_Edge_Attributes, No_Value => No_Library_Graph_Edge_Attributes, @@ -1110,20 +1524,25 @@ package Bindo.Graphs is -- The following type represents the attributes of a component type Component_Attributes is record - Pending_Predecessors : Natural := 0; - -- The number of pending predecessor components this component must - -- wait on before it can be elaborated. + Pending_Strong_Predecessors : Natural := 0; + -- The number of pending strong predecessor components this component + -- must wait on before it can be elaborated. + + Pending_Weak_Predecessors : Natural := 0; + -- The number of pending weak predecessor components this component + -- must wait on before it can be elaborated. end record; No_Component_Attributes : constant Component_Attributes := - (Pending_Predecessors => 0); + (Pending_Strong_Predecessors => 0, + Pending_Weak_Predecessors => 0); procedure Destroy_Component_Attributes (Attrs : in out Component_Attributes); pragma Inline (Destroy_Component_Attributes); -- Destroy the contents of attributes Attrs - package CA is new Dynamic_Hash_Tables + package Component_Tables is new Dynamic_Hash_Tables (Key_Type => Component_Id, Value_Type => Component_Attributes, No_Value => No_Component_Attributes, @@ -1135,9 +1554,60 @@ package Bindo.Graphs is Destroy_Value => Destroy_Component_Attributes, Hash => Hash_Component); - --------------- - -- Relations -- - --------------- + ------------ + -- Cycles -- + ------------ + + -- The following type represents the attributes of a cycle + + type Library_Graph_Cycle_Attributes is record + Invocation_Edge_Count : Natural := 0; + -- The number of invocation edges within the cycle + + Kind : Library_Graph_Cycle_Kind := No_Cycle_Kind; + -- The nature of the cycle + + Path : LGE_Lists.Doubly_Linked_List := LGE_Lists.Nil; + -- The path of edges that form the cycle + end record; + + No_Library_Graph_Cycle_Attributes : + constant Library_Graph_Cycle_Attributes := + (Invocation_Edge_Count => 0, + Kind => No_Cycle_Kind, + Path => LGE_Lists.Nil); + + procedure Destroy_Library_Graph_Cycle_Attributes + (Attrs : in out Library_Graph_Cycle_Attributes); + pragma Inline (Destroy_Library_Graph_Cycle_Attributes); + -- Destroy the contents of attributes Attrs + + function Hash_Library_Graph_Cycle_Attributes + (Attrs : Library_Graph_Cycle_Attributes) return Bucket_Range_Type; + pragma Inline (Hash_Library_Graph_Cycle_Attributes); + -- Obtain the hash of key Attrs + + function Same_Library_Graph_Cycle_Attributes + (Left : Library_Graph_Cycle_Attributes; + Right : Library_Graph_Cycle_Attributes) return Boolean; + pragma Inline (Same_Library_Graph_Cycle_Attributes); + -- Determine whether cycle attributes Left and Right are the same + + package LGC_Tables is new Dynamic_Hash_Tables + (Key_Type => Library_Graph_Cycle_Id, + Value_Type => Library_Graph_Cycle_Attributes, + No_Value => No_Library_Graph_Cycle_Attributes, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Library_Graph_Cycle_Attributes, + Hash => Hash_Library_Graph_Cycle); + + -------------------- + -- Recorded edges -- + -------------------- -- The following type represents a relation between a predecessor and -- successor vertices. @@ -1160,7 +1630,7 @@ package Bindo.Graphs is pragma Inline (Hash_Predecessor_Successor_Relation); -- Obtain the hash value of key Rel - package PS is new Membership_Sets + package RE_Sets is new Membership_Sets (Element_Type => Predecessor_Successor_Relation, "=" => "=", Hash => Hash_Predecessor_Successor_Relation); @@ -1176,7 +1646,7 @@ package Bindo.Graphs is -- Units -- ----------- - package UV is new Dynamic_Hash_Tables + package Unit_Tables is new Dynamic_Hash_Tables (Key_Type => Unit_Id, Value_Type => Library_Graph_Vertex_Id, No_Value => No_Library_Graph_Vertex, @@ -1205,28 +1675,35 @@ package Bindo.Graphs is -- The following type represents the attributes of a library graph type Library_Graph_Attributes is record - Component_Attributes : CA.Dynamic_Hash_Table := CA.Nil; + Component_Attributes : Component_Tables.Dynamic_Hash_Table := + Component_Tables.Nil; -- The map of component -> component attributes for all components in -- the graph. Counts : Library_Graph_Edge_Counts := (others => 0); -- Edge statistics - Edge_Attributes : EA.Dynamic_Hash_Table := EA.Nil; + Cycle_Attributes : LGC_Tables.Dynamic_Hash_Table := LGC_Tables.Nil; + -- The map of cycle -> cycle attributes for all cycles in the graph + + Cycles : LGC_Lists.Doubly_Linked_List := LGC_Lists.Nil; + -- The list of all cycles in the graph, sorted based on precedence + + Edge_Attributes : LGE_Tables.Dynamic_Hash_Table := LGE_Tables.Nil; -- The map of edge -> edge attributes for all edges in the graph Graph : DG.Directed_Graph := DG.Nil; -- The underlying graph describing the relations between edges and -- vertices. - Relations : PS.Membership_Set := PS.Nil; - -- The set of relations between successors and predecessors, used to - -- prevent duplicate edges in the graph. + Recorded_Edges : RE_Sets.Membership_Set := RE_Sets.Nil; + -- The set of recorded edges, used to prevent duplicate edges in the + -- graph. - Unit_To_Vertex : UV.Dynamic_Hash_Table := UV.Nil; + Unit_To_Vertex : Unit_Tables.Dynamic_Hash_Table := Unit_Tables.Nil; -- The map of unit -> vertex - Vertex_Attributes : VA.Dynamic_Hash_Table := VA.Nil; + Vertex_Attributes : LGV_Tables.Dynamic_Hash_Table := LGV_Tables.Nil; -- The map of vertex -> vertex attributes for all vertices in the -- graph. end record; @@ -1238,10 +1715,12 @@ package Bindo.Graphs is -- Iterators -- --------------- + type All_Cycle_Iterator is new LGC_Lists.Iterator; type All_Edge_Iterator is new DG.All_Edge_Iterator; type All_Vertex_Iterator is new DG.All_Vertex_Iterator; type Component_Iterator is new DG.Component_Iterator; type Component_Vertex_Iterator is new DG.Component_Vertex_Iterator; + type Edges_Of_Cycle_Iterator is new LGE_Lists.Iterator; type Edges_To_Successors_Iterator is new DG.Outgoing_Edge_Iterator; end Library_Graphs; diff --git a/gcc/ada/bindo-units.adb b/gcc/ada/bindo-units.adb index de0afb9..284aa62 100644 --- a/gcc/ada/bindo-units.adb +++ b/gcc/ada/bindo-units.adb @@ -23,13 +23,17 @@ -- -- ------------------------------------------------------------------------------ +with Bindo.Writers; +use Bindo.Writers; +use Bindo.Writers.Phase_Writers; + package body Bindo.Units is ------------------- -- Signature set -- ------------------- - package SS is new Membership_Sets + package Signature_Sets is new Membership_Sets (Element_Type => Invocation_Signature_Id, "=" => "=", Hash => Hash_Invocation_Signature); @@ -41,11 +45,11 @@ package body Bindo.Units is -- The following set stores all invocation signatures that appear in -- elaborable units. - Elaborable_Constructs : SS.Membership_Set := SS.Nil; + Elaborable_Constructs : Signature_Sets.Membership_Set := Signature_Sets.Nil; -- The following set stores all units the need to be elaborated - Elaborable_Units : US.Membership_Set := US.Nil; + Elaborable_Units : Unit_Sets.Membership_Set := Unit_Sets.Nil; ----------------------- -- Local subprograms -- @@ -79,9 +83,13 @@ package body Bindo.Units is procedure Collect_Elaborable_Units is begin + Start_Phase (Unit_Collection); + for U_Id in ALI.Units.First .. ALI.Units.Last loop Process_Unit (U_Id); end loop; + + End_Phase (Unit_Collection); end Collect_Elaborable_Units; ------------------------ @@ -139,14 +147,27 @@ package body Bindo.Units is return Corresponding_Unit (Name_Id (UNam)); end Corresponding_Unit; + --------------- + -- File_Name -- + --------------- + + function File_Name (U_Id : Unit_Id) return File_Name_Type is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Sfile; + end File_Name; + -------------------- -- Finalize_Units -- -------------------- procedure Finalize_Units is begin - SS.Destroy (Elaborable_Constructs); - US.Destroy (Elaborable_Units); + Signature_Sets.Destroy (Elaborable_Constructs); + Unit_Sets.Destroy (Elaborable_Units); end Finalize_Units; ------------------------------ @@ -183,9 +204,22 @@ package body Bindo.Units is function Has_Next (Iter : Elaborable_Units_Iterator) return Boolean is begin - return US.Has_Next (US.Iterator (Iter)); + return Unit_Sets.Has_Next (Unit_Sets.Iterator (Iter)); end Has_Next; + ----------------------------- + -- Has_No_Elaboration_Code -- + ----------------------------- + + function Has_No_Elaboration_Code (U_Id : Unit_Id) return Boolean is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.No_Elab; + end Has_No_Elaboration_Code; + ------------------------------- -- Hash_Invocation_Signature -- ------------------------------- @@ -216,11 +250,27 @@ package body Bindo.Units is procedure Initialize_Units is begin - Elaborable_Constructs := SS.Create (Number_Of_Units); - Elaborable_Units := US.Create (Number_Of_Units); + Elaborable_Constructs := Signature_Sets.Create (Number_Of_Units); + Elaborable_Units := Unit_Sets.Create (Number_Of_Units); end Initialize_Units; ------------------------------- + -- Invocation_Graph_Encoding -- + ------------------------------- + + function Invocation_Graph_Encoding + (U_Id : Unit_Id) return Invocation_Graph_Encoding_Kind + is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + U_ALI : ALIs_Record renames ALI.ALIs.Table (U_Rec.My_ALI); + + begin + return U_ALI.Invocation_Graph_Encoding; + end Invocation_Graph_Encoding; + + ------------------------------- -- Is_Dynamically_Elaborated -- ------------------------------- @@ -278,7 +328,7 @@ package body Bindo.Units is function Iterate_Elaborable_Units return Elaborable_Units_Iterator is begin - return Elaborable_Units_Iterator (US.Iterate (Elaborable_Units)); + return Elaborable_Units_Iterator (Unit_Sets.Iterate (Elaborable_Units)); end Iterate_Elaborable_Units; ---------- @@ -304,7 +354,7 @@ package body Bindo.Units is begin pragma Assert (Present (IS_Id)); - return SS.Contains (Elaborable_Constructs, IS_Id); + return Signature_Sets.Contains (Elaborable_Constructs, IS_Id); end Needs_Elaboration; ----------------------- @@ -315,7 +365,7 @@ package body Bindo.Units is begin pragma Assert (Present (U_Id)); - return US.Contains (Elaborable_Units, U_Id); + return Unit_Sets.Contains (Elaborable_Units, U_Id); end Needs_Elaboration; ---------- @@ -327,7 +377,7 @@ package body Bindo.Units is U_Id : out Unit_Id) is begin - US.Next (US.Iterator (Iter), U_Id); + Unit_Sets.Next (Unit_Sets.Iterator (Iter), U_Id); end Next; -------------------------------- @@ -336,7 +386,7 @@ package body Bindo.Units is function Number_Of_Elaborable_Units return Natural is begin - return US.Size (Elaborable_Units); + return Unit_Sets.Size (Elaborable_Units); end Number_Of_Elaborable_Units; --------------------- @@ -355,14 +405,12 @@ package body Bindo.Units is procedure Process_Invocation_Construct (IC_Id : Invocation_Construct_Id) is pragma Assert (Present (IC_Id)); - IC_Rec : Invocation_Construct_Record renames - Invocation_Constructs.Table (IC_Id); - IC_Sig : constant Invocation_Signature_Id := IC_Rec.Signature; + IS_Id : constant Invocation_Signature_Id := Signature (IC_Id); - pragma Assert (Present (IC_Sig)); + pragma Assert (Present (IS_Id)); begin - SS.Insert (Elaborable_Constructs, IC_Sig); + Signature_Sets.Insert (Elaborable_Constructs, IS_Id); end Process_Invocation_Construct; ----------------------------------- @@ -402,7 +450,7 @@ package body Bindo.Units is -- signatures of constructs it declares. else - US.Insert (Elaborable_Units, U_Id); + Unit_Sets.Insert (Elaborable_Units, U_Id); Process_Invocation_Constructs (U_Id); end if; end Process_Unit; diff --git a/gcc/ada/bindo-units.ads b/gcc/ada/bindo-units.ads index 93caadf..5f045c8 100644 --- a/gcc/ada/bindo-units.ads +++ b/gcc/ada/bindo-units.ads @@ -33,6 +33,19 @@ with GNAT.Sets; use GNAT.Sets; package Bindo.Units is + --------------- + -- Unit sets -- + --------------- + + function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type; + pragma Inline (Hash_Unit); + -- Obtain the hash value of key U_Id + + package Unit_Sets is new Membership_Sets + (Element_Type => Unit_Id, + "=" => "=", + Hash => Hash_Unit); + procedure Collect_Elaborable_Units; pragma Inline (Collect_Elaborable_Units); -- Gather all units in the bind that require elaboration. The units are @@ -54,6 +67,10 @@ package Bindo.Units is pragma Inline (Corresponding_Unit); -- Obtain the unit which corresponds to name FNam + function File_Name (U_Id : Unit_Id) return File_Name_Type; + pragma Inline (File_Name); + -- Obtain the file name of unit U_Id + type Unit_Processor_Ptr is access procedure (U_Id : Unit_Id); procedure For_Each_Elaborable_Unit (Processor : Unit_Processor_Ptr); @@ -64,14 +81,20 @@ package Bindo.Units is pragma Inline (For_Each_Unit); -- Invoke Processor on each unit in the bind + function Has_No_Elaboration_Code (U_Id : Unit_Id) return Boolean; + pragma Inline (Has_No_Elaboration_Code); + -- Determine whether unit U_Id lacks elaboration code + function Hash_Invocation_Signature (IS_Id : Invocation_Signature_Id) return Bucket_Range_Type; pragma Inline (Hash_Invocation_Signature); -- Obtain the hash value of key IS_Id - function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type; - pragma Inline (Hash_Unit); - -- Obtain the hash value of key U_Id + function Invocation_Graph_Encoding + (U_Id : Unit_Id) return Invocation_Graph_Encoding_Kind; + pragma Inline (Invocation_Graph_Encoding); + -- Obtain the encoding format used to capture invocation constructs and + -- relations in the ALI file of unit U_Id. function Is_Dynamically_Elaborated (U_Id : Unit_Id) return Boolean; pragma Inline (Is_Dynamically_Elaborated); @@ -144,11 +167,6 @@ package Bindo.Units is -- Initialize the internal structures of this unit private - package US is new Membership_Sets - (Element_Type => Unit_Id, - "=" => "=", - Hash => Hash_Unit); - - type Elaborable_Units_Iterator is new US.Iterator; + type Elaborable_Units_Iterator is new Unit_Sets.Iterator; end Bindo.Units; diff --git a/gcc/ada/bindo-validators.adb b/gcc/ada/bindo-validators.adb index 54d2fc6..584d33f 100644 --- a/gcc/ada/bindo-validators.adb +++ b/gcc/ada/bindo-validators.adb @@ -27,24 +27,194 @@ with Debug; use Debug; with Output; use Output; with Types; use Types; -with Bindo.Units; use Bindo.Units; +with Bindo.Units; +use Bindo.Units; -with GNAT; use GNAT; -with GNAT.Sets; use GNAT.Sets; +with Bindo.Writers; +use Bindo.Writers; +use Bindo.Writers.Phase_Writers; package body Bindo.Validators is + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Error + (Msg : String; + Flag : out Boolean); + pragma Inline (Write_Error); + -- Write error message Msg to standard output and set flag Flag to True + + ---------------------- + -- Cycle_Validators -- + ---------------------- + + package body Cycle_Validators is + Has_Invalid_Cycle : Boolean := False; + -- Flag set when the library graph contains an invalid cycle + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Validate_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id); + pragma Inline (Validate_Cycle); + -- Ensure that a cycle meets the following requirements: + -- + -- * Is of proper kind + -- * Has enough edges to form a circuit + -- * No edge is repeated + + procedure Validate_Cycle_Path + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id); + pragma Inline (Validate_Cycle_Path); + -- Ensure that the path of a cycle meets the following requirements: + -- + -- * No edge is repeated + + -------------------- + -- Validate_Cycle -- + -------------------- + + procedure Validate_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) + is + Msg : constant String := "Validate_Cycle"; + + begin + pragma Assert (Present (G)); + + if not Present (Cycle) then + Write_Error (Msg, Has_Invalid_Cycle); + + Write_Str (" empty cycle"); + Write_Eol; + Write_Eol; + return; + end if; + + if Kind (G, Cycle) = No_Cycle_Kind then + Write_Error (Msg, Has_Invalid_Cycle); + + Write_Str (" cycle (LGC_Id_"); + Write_Int (Int (Cycle)); + Write_Str (") is a No_Cycle"); + Write_Eol; + Write_Eol; + end if; + + -- A cycle requires at least one edge (self cycle) to form a circuit + + if Length (G, Cycle) < 1 then + Write_Error (Msg, Has_Invalid_Cycle); + + Write_Str (" cycle (LGC_Id_"); + Write_Int (Int (Cycle)); + Write_Str (") does not contain enough edges"); + Write_Eol; + Write_Eol; + end if; + + Validate_Cycle_Path (G, Cycle); + end Validate_Cycle; + + ------------------------- + -- Validate_Cycle_Path -- + ------------------------- + + procedure Validate_Cycle_Path + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) + is + Msg : constant String := "Validate_Cycle_Path"; + + Edge : Library_Graph_Edge_Id; + Edges : LGE_Sets.Membership_Set; + Iter : Edges_Of_Cycle_Iterator; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + -- Use a set to detect duplicate edges while traversing the cycle + + Edges := LGE_Sets.Create (Length (G, Cycle)); + + -- Inspect the edges of the cycle, trying to catch duplicates + + Iter := Iterate_Edges_Of_Cycle (G, Cycle); + while Has_Next (Iter) loop + Next (Iter, Edge); + + -- The current edge has already been encountered while traversing + -- the cycle. This indicates that the cycle is malformed as edges + -- are not repeated in the circuit. + + if LGE_Sets.Contains (Edges, Edge) then + Write_Error (Msg, Has_Invalid_Cycle); + + Write_Str (" library graph edge (LGE_Id_"); + Write_Int (Int (Edge)); + Write_Str (") is repeated in cycle (LGC_Id_"); + Write_Int (Int (Cycle)); + Write_Str (")"); + Write_Eol; + + -- Otherwise add the current edge to the set of encountered edges + + else + LGE_Sets.Insert (Edges, Edge); + end if; + end loop; + + LGE_Sets.Destroy (Edges); + end Validate_Cycle_Path; + + --------------------- + -- Validate_Cycles -- + --------------------- + + procedure Validate_Cycles (G : Library_Graph) is + Cycle : Library_Graph_Cycle_Id; + Iter : All_Cycle_Iterator; + + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and + -- order) is not in effect. + + if not Debug_Flag_Underscore_VV then + return; + end if; + + Start_Phase (Cycle_Validation); + + Iter := Iterate_All_Cycles (G); + while Has_Next (Iter) loop + Next (Iter, Cycle); + + Validate_Cycle (G, Cycle); + end loop; + + End_Phase (Cycle_Validation); + + if Has_Invalid_Cycle then + raise Invalid_Cycle; + end if; + end Validate_Cycles; + end Cycle_Validators; + ---------------------------------- -- Elaboration_Order_Validators -- ---------------------------------- package body Elaboration_Order_Validators is - package US is new Membership_Sets - (Element_Type => Unit_Id, - "=" => "=", - Hash => Hash_Unit); - use US; - Has_Invalid_Data : Boolean := False; -- Flag set when the elaboration order contains invalid data @@ -52,7 +222,7 @@ package body Bindo.Validators is -- Local subprograms -- ----------------------- - function Build_Elaborable_Unit_Set return Membership_Set; + function Build_Elaborable_Unit_Set return Unit_Sets.Membership_Set; pragma Inline (Build_Elaborable_Unit_Set); -- Create a set from all units that need to be elaborated @@ -61,7 +231,7 @@ package body Bindo.Validators is -- Emit an error concerning unit U_Id that must be elaborated, but was -- not. - procedure Report_Missing_Elaborations (Set : Membership_Set); + procedure Report_Missing_Elaborations (Set : Unit_Sets.Membership_Set); pragma Inline (Report_Missing_Elaborations); -- Emit errors on all units in set Set that must be elaborated, but were -- not. @@ -70,7 +240,9 @@ package body Bindo.Validators is pragma Inline (Report_Spurious_Elaboration); -- Emit an error concerning unit U_Id that is incorrectly elaborated - procedure Validate_Unit (U_Id : Unit_Id; Elab_Set : Membership_Set); + procedure Validate_Unit + (U_Id : Unit_Id; + Elab_Set : Unit_Sets.Membership_Set); pragma Inline (Validate_Unit); -- Validate the elaboration status of unit U_Id. Elab_Set is the set of -- all units that need to be elaborated. @@ -79,28 +251,22 @@ package body Bindo.Validators is pragma Inline (Validate_Units); -- Validate all units in elaboration order Order - procedure Write_Error (Msg : String); - pragma Inline (Write_Error); - -- Write error message Msg to standard output and signal that the - -- elaboration order is incorrect. - ------------------------------- -- Build_Elaborable_Unit_Set -- ------------------------------- - function Build_Elaborable_Unit_Set return Membership_Set is + function Build_Elaborable_Unit_Set return Unit_Sets.Membership_Set is Iter : Elaborable_Units_Iterator; - Set : Membership_Set; + Set : Unit_Sets.Membership_Set; U_Id : Unit_Id; begin - Set := Create (Number_Of_Elaborable_Units); + Set := Unit_Sets.Create (Number_Of_Elaborable_Units); Iter := Iterate_Elaborable_Units; while Has_Next (Iter) loop Next (Iter, U_Id); - pragma Assert (Present (U_Id)); - Insert (Set, U_Id); + Unit_Sets.Insert (Set, U_Id); end loop; return Set; @@ -115,7 +281,7 @@ package body Bindo.Validators is begin pragma Assert (Present (U_Id)); - Write_Error (Msg); + Write_Error (Msg, Has_Invalid_Data); Write_Str ("unit (U_Id_"); Write_Int (Int (U_Id)); @@ -129,15 +295,14 @@ package body Bindo.Validators is -- Report_Missing_Elaborations -- --------------------------------- - procedure Report_Missing_Elaborations (Set : Membership_Set) is - Iter : Iterator; + procedure Report_Missing_Elaborations (Set : Unit_Sets.Membership_Set) is + Iter : Unit_Sets.Iterator; U_Id : Unit_Id; begin - Iter := Iterate (Set); - while Has_Next (Iter) loop - Next (Iter, U_Id); - pragma Assert (Present (U_Id)); + Iter := Unit_Sets.Iterate (Set); + while Unit_Sets.Has_Next (Iter) loop + Unit_Sets.Next (Iter, U_Id); Report_Missing_Elaboration (U_Id); end loop; @@ -152,7 +317,7 @@ package body Bindo.Validators is begin pragma Assert (Present (U_Id)); - Write_Error (Msg); + Write_Error (Msg, Has_Invalid_Data); Write_Str ("unit (U_Id_"); Write_Int (Int (U_Id)); @@ -167,15 +332,19 @@ package body Bindo.Validators is procedure Validate_Elaboration_Order (Order : Unit_Id_Table) is begin - -- Nothing to do when switch -d_V (validate bindo graphs and order) - -- is not in effect. + -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and + -- order) is not in effect. if not Debug_Flag_Underscore_VV then return; end if; + Start_Phase (Elaboration_Order_Validation); + Validate_Units (Order); + End_Phase (Elaboration_Order_Validation); + if Has_Invalid_Data then raise Invalid_Elaboration_Order; end if; @@ -185,15 +354,18 @@ package body Bindo.Validators is -- Validate_Unit -- ------------------- - procedure Validate_Unit (U_Id : Unit_Id; Elab_Set : Membership_Set) is + procedure Validate_Unit + (U_Id : Unit_Id; + Elab_Set : Unit_Sets.Membership_Set) + is begin pragma Assert (Present (U_Id)); -- The current unit in the elaboration order appears within the set -- of units that require elaboration. Remove it from the set. - if Contains (Elab_Set, U_Id) then - Delete (Elab_Set, U_Id); + if Unit_Sets.Contains (Elab_Set, U_Id) then + Unit_Sets.Delete (Elab_Set, U_Id); -- Otherwise the current unit in the elaboration order must not be -- elaborated. @@ -208,7 +380,7 @@ package body Bindo.Validators is -------------------- procedure Validate_Units (Order : Unit_Id_Table) is - Elab_Set : Membership_Set; + Elab_Set : Unit_Sets.Membership_Set; begin -- Collect all units in the compilation that need to be elaborated @@ -219,7 +391,7 @@ package body Bindo.Validators is -- Validate each unit in the elaboration order against the set of -- units that need to be elaborated. - for Index in Unit_Id_Tables.First .. Unit_Id_Tables.Last (Order) loop + for Index in Unit_Id_Tables.First .. Unit_Id_Tables.Last (Order) loop Validate_Unit (U_Id => Order.Table (Index), Elab_Set => Elab_Set); @@ -230,21 +402,8 @@ package body Bindo.Validators is -- their elaboration. Report_Missing_Elaborations (Elab_Set); - Destroy (Elab_Set); + Unit_Sets.Destroy (Elab_Set); end Validate_Units; - - ----------------- - -- Write_Error -- - ----------------- - - procedure Write_Error (Msg : String) is - begin - Has_Invalid_Data := True; - - Write_Str ("ERROR: "); - Write_Str (Msg); - Write_Eol; - end Write_Error; end Elaboration_Order_Validators; --------------------------------- @@ -260,10 +419,10 @@ package body Bindo.Validators is ----------------------- procedure Validate_Invocation_Graph_Edge - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id); + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id); pragma Inline (Validate_Invocation_Graph_Edge); - -- Verify that the attributes of edge IGE_Id of invocation graph G are + -- Verify that the attributes of edge Edge of invocation graph G are -- properly set. procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph); @@ -273,9 +432,9 @@ package body Bindo.Validators is procedure Validate_Invocation_Graph_Vertex (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id); + Vertex : Invocation_Graph_Vertex_Id); pragma Inline (Validate_Invocation_Graph_Vertex); - -- Verify that the attributes of vertex IGV_Id of inbocation graph G are + -- Verify that the attributes of vertex Vertex of invocation graph G are -- properly set. procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph); @@ -283,11 +442,6 @@ package body Bindo.Validators is -- Verify that the attributes of all vertices of invocation graph G are -- properly set. - procedure Write_Error (Msg : String); - pragma Inline (Write_Error); - -- Write error message Msg to standard output and signal that the - -- invocation graph is incorrect. - ------------------------------- -- Validate_Invocation_Graph -- ------------------------------- @@ -296,15 +450,19 @@ package body Bindo.Validators is begin pragma Assert (Present (G)); - -- Nothing to do when switch -d_V (validate bindo graphs and order) - -- is not in effect. + -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and + -- order) is not in effect. if not Debug_Flag_Underscore_VV then return; end if; + Start_Phase (Invocation_Graph_Validation); + Validate_Invocation_Graph_Vertices (G); - Validate_Invocation_Graph_Edges (G); + Validate_Invocation_Graph_Edges (G); + + End_Phase (Invocation_Graph_Validation); if Has_Invalid_Data then raise Invalid_Invocation_Graph; @@ -316,38 +474,38 @@ package body Bindo.Validators is ------------------------------------ procedure Validate_Invocation_Graph_Edge - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) is Msg : constant String := "Validate_Invocation_Graph_Edge"; begin pragma Assert (Present (G)); - if not Present (IGE_Id) then - Write_Error (Msg); + if not Present (Edge) then + Write_Error (Msg, Has_Invalid_Data); - Write_Str (" emply invocation graph edge"); + Write_Str (" empty invocation graph edge"); Write_Eol; Write_Eol; return; end if; - if not Present (Relation (G, IGE_Id)) then - Write_Error (Msg); + if not Present (Relation (G, Edge)) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" invocation graph edge (IGE_Id_"); - Write_Int (Int (IGE_Id)); + Write_Int (Int (Edge)); Write_Str (") lacks Relation"); Write_Eol; Write_Eol; end if; - if not Present (Target (G, IGE_Id)) then - Write_Error (Msg); + if not Present (Target (G, Edge)) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" invocation graph edge (IGE_Id_"); - Write_Int (Int (IGE_Id)); + Write_Int (Int (Edge)); Write_Str (") lacks Target"); Write_Eol; Write_Eol; @@ -359,17 +517,17 @@ package body Bindo.Validators is ------------------------------------- procedure Validate_Invocation_Graph_Edges (G : Invocation_Graph) is - IGE_Id : Invocation_Graph_Edge_Id; - Iter : Invocation_Graphs.All_Edge_Iterator; + Edge : Invocation_Graph_Edge_Id; + Iter : Invocation_Graphs.All_Edge_Iterator; begin pragma Assert (Present (G)); Iter := Iterate_All_Edges (G); while Has_Next (Iter) loop - Next (Iter, IGE_Id); + Next (Iter, Edge); - Validate_Invocation_Graph_Edge (G, IGE_Id); + Validate_Invocation_Graph_Edge (G, Edge); end loop; end Validate_Invocation_Graph_Edges; @@ -379,38 +537,48 @@ package body Bindo.Validators is procedure Validate_Invocation_Graph_Vertex (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) + Vertex : Invocation_Graph_Vertex_Id) is Msg : constant String := "Validate_Invocation_Graph_Vertex"; begin pragma Assert (Present (G)); - if not Present (IGV_Id) then - Write_Error (Msg); + if not Present (Vertex) then + Write_Error (Msg, Has_Invalid_Data); - Write_Str (" emply invocation graph vertex"); + Write_Str (" empty invocation graph vertex"); Write_Eol; Write_Eol; return; end if; - if not Present (Construct (G, IGV_Id)) then - Write_Error (Msg); + if not Present (Body_Vertex (G, Vertex)) then + Write_Error (Msg, Has_Invalid_Data); + + Write_Str (" invocation graph vertex (IGV_Id_"); + Write_Int (Int (Vertex)); + Write_Str (") lacks Body_Vertex"); + Write_Eol; + Write_Eol; + end if; + + if not Present (Construct (G, Vertex)) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" invocation graph vertex (IGV_Id_"); - Write_Int (Int (IGV_Id)); + Write_Int (Int (Vertex)); Write_Str (") lacks Construct"); Write_Eol; Write_Eol; end if; - if not Present (Lib_Vertex (G, IGV_Id)) then - Write_Error (Msg); + if not Present (Spec_Vertex (G, Vertex)) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" invocation graph vertex (IGV_Id_"); - Write_Int (Int (IGV_Id)); - Write_Str (") lacks Lib_Vertex"); + Write_Int (Int (Vertex)); + Write_Str (") lacks Spec_Vertex"); Write_Eol; Write_Eol; end if; @@ -421,32 +589,19 @@ package body Bindo.Validators is ---------------------------------------- procedure Validate_Invocation_Graph_Vertices (G : Invocation_Graph) is - IGV_Id : Invocation_Graph_Vertex_Id; Iter : Invocation_Graphs.All_Vertex_Iterator; + Vertex : Invocation_Graph_Vertex_Id; begin pragma Assert (Present (G)); Iter := Iterate_All_Vertices (G); while Has_Next (Iter) loop - Next (Iter, IGV_Id); + Next (Iter, Vertex); - Validate_Invocation_Graph_Vertex (G, IGV_Id); + Validate_Invocation_Graph_Vertex (G, Vertex); end loop; end Validate_Invocation_Graph_Vertices; - - ----------------- - -- Write_Error -- - ----------------- - - procedure Write_Error (Msg : String) is - begin - Has_Invalid_Data := True; - - Write_Str ("ERROR: "); - Write_Str (Msg); - Write_Eol; - end Write_Error; end Invocation_Graph_Validators; ------------------------------ @@ -462,10 +617,10 @@ package body Bindo.Validators is ----------------------- procedure Validate_Library_Graph_Edge - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id); + (G : Library_Graph; + Edge : Library_Graph_Edge_Id); pragma Inline (Validate_Library_Graph_Edge); - -- Verify that the attributes of edge LGE_Id of library graph G are + -- Verify that the attributes of edge Edge of library graph G are -- properly set. procedure Validate_Library_Graph_Edges (G : Library_Graph); @@ -475,9 +630,9 @@ package body Bindo.Validators is procedure Validate_Library_Graph_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id); + Vertex : Library_Graph_Vertex_Id); pragma Inline (Validate_Library_Graph_Vertex); - -- Verify that the attributes of vertex LGV_Id of library graph G are + -- Verify that the attributes of vertex Vertex of library graph G are -- properly set. procedure Validate_Library_Graph_Vertices (G : Library_Graph); @@ -485,11 +640,6 @@ package body Bindo.Validators is -- Verify that the attributes of all vertices of library graph G are -- properly set. - procedure Write_Error (Msg : String); - pragma Inline (Write_Error); - -- Write error message Msg to standard output and signal that the - -- library graph is incorrect. - ---------------------------- -- Validate_Library_Graph -- ---------------------------- @@ -498,15 +648,19 @@ package body Bindo.Validators is begin pragma Assert (Present (G)); - -- Nothing to do when switch -d_V (validate bindo graphs and order) - -- is not in effect. + -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and + -- order) is not in effect. if not Debug_Flag_Underscore_VV then return; end if; + Start_Phase (Library_Graph_Validation); + Validate_Library_Graph_Vertices (G); - Validate_Library_Graph_Edges (G); + Validate_Library_Graph_Edges (G); + + End_Phase (Library_Graph_Validation); if Has_Invalid_Data then raise Invalid_Library_Graph; @@ -518,57 +672,57 @@ package body Bindo.Validators is --------------------------------- procedure Validate_Library_Graph_Edge - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) is Msg : constant String := "Validate_Library_Graph_Edge"; begin pragma Assert (Present (G)); - if not Present (LGE_Id) then - Write_Error (Msg); + if not Present (Edge) then + Write_Error (Msg, Has_Invalid_Data); - Write_Str (" emply library graph edge"); + Write_Str (" empty library graph edge"); Write_Eol; Write_Eol; return; end if; - if Kind (G, LGE_Id) = No_Edge then - Write_Error (Msg); + if Kind (G, Edge) = No_Edge then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" library graph edge (LGE_Id_"); - Write_Int (Int (LGE_Id)); + Write_Int (Int (Edge)); Write_Str (") is not a valid edge"); Write_Eol; Write_Eol; - elsif Kind (G, LGE_Id) = Body_Before_Spec_Edge then - Write_Error (Msg); + elsif Kind (G, Edge) = Body_Before_Spec_Edge then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" library graph edge (LGE_Id_"); - Write_Int (Int (LGE_Id)); + Write_Int (Int (Edge)); Write_Str (") is a Body_Before_Spec edge"); Write_Eol; Write_Eol; end if; - if not Present (Predecessor (G, LGE_Id)) then - Write_Error (Msg); + if not Present (Predecessor (G, Edge)) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" library graph edge (LGE_Id_"); - Write_Int (Int (LGE_Id)); + Write_Int (Int (Edge)); Write_Str (") lacks Predecessor"); Write_Eol; Write_Eol; end if; - if not Present (Successor (G, LGE_Id)) then - Write_Error (Msg); + if not Present (Successor (G, Edge)) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" library graph edge (LGE_Id_"); - Write_Int (Int (LGE_Id)); + Write_Int (Int (Edge)); Write_Str (") lacks Successor"); Write_Eol; Write_Eol; @@ -580,18 +734,17 @@ package body Bindo.Validators is ---------------------------------- procedure Validate_Library_Graph_Edges (G : Library_Graph) is - Iter : Library_Graphs.All_Edge_Iterator; - LGE_Id : Library_Graph_Edge_Id; + Edge : Library_Graph_Edge_Id; + Iter : Library_Graphs.All_Edge_Iterator; begin pragma Assert (Present (G)); Iter := Iterate_All_Edges (G); while Has_Next (Iter) loop - Next (Iter, LGE_Id); - pragma Assert (Present (LGE_Id)); + Next (Iter, Edge); - Validate_Library_Graph_Edge (G, LGE_Id); + Validate_Library_Graph_Edge (G, Edge); end loop; end Validate_Library_Graph_Edges; @@ -601,15 +754,15 @@ package body Bindo.Validators is procedure Validate_Library_Graph_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id) is Msg : constant String := "Validate_Library_Graph_Vertex"; begin pragma Assert (Present (G)); - if not Present (LGV_Id) then - Write_Error (Msg); + if not Present (Vertex) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" empty library graph vertex"); Write_Eol; @@ -617,25 +770,25 @@ package body Bindo.Validators is return; end if; - if (Is_Body_With_Spec (G, LGV_Id) + if (Is_Body_With_Spec (G, Vertex) or else - Is_Spec_With_Body (G, LGV_Id)) - and then not Present (Corresponding_Item (G, LGV_Id)) + Is_Spec_With_Body (G, Vertex)) + and then not Present (Corresponding_Item (G, Vertex)) then - Write_Error (Msg); + Write_Error (Msg, Has_Invalid_Data); Write_Str (" library graph vertex (LGV_Id_"); - Write_Int (Int (LGV_Id)); + Write_Int (Int (Vertex)); Write_Str (") lacks Corresponding_Item"); Write_Eol; Write_Eol; end if; - if not Present (Unit (G, LGV_Id)) then - Write_Error (Msg); + if not Present (Unit (G, Vertex)) then + Write_Error (Msg, Has_Invalid_Data); Write_Str (" library graph vertex (LGV_Id_"); - Write_Int (Int (LGV_Id)); + Write_Int (Int (Vertex)); Write_Str (") lacks Unit"); Write_Eol; Write_Eol; @@ -648,32 +801,34 @@ package body Bindo.Validators is procedure Validate_Library_Graph_Vertices (G : Library_Graph) is Iter : Library_Graphs.All_Vertex_Iterator; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; begin pragma Assert (Present (G)); Iter := Iterate_All_Vertices (G); while Has_Next (Iter) loop - Next (Iter, LGV_Id); - pragma Assert (Present (LGV_Id)); + Next (Iter, Vertex); - Validate_Library_Graph_Vertex (G, LGV_Id); + Validate_Library_Graph_Vertex (G, Vertex); end loop; end Validate_Library_Graph_Vertices; - - ----------------- - -- Write_Error -- - ----------------- - - procedure Write_Error (Msg : String) is - begin - Has_Invalid_Data := True; - - Write_Str ("ERROR: "); - Write_Str (Msg); - Write_Eol; - end Write_Error; end Library_Graph_Validators; + ----------------- + -- Write_Error -- + ----------------- + + procedure Write_Error + (Msg : String; + Flag : out Boolean) + is + begin + Write_Str ("ERROR: "); + Write_Str (Msg); + Write_Eol; + + Flag := True; + end Write_Error; + end Bindo.Validators; diff --git a/gcc/ada/bindo-validators.ads b/gcc/ada/bindo-validators.ads index 39fccc6..d70447b 100644 --- a/gcc/ada/bindo-validators.ads +++ b/gcc/ada/bindo-validators.ads @@ -35,6 +35,26 @@ use Bindo.Graphs.Library_Graphs; package Bindo.Validators is + ---------------------- + -- Cycle_Validators -- + ---------------------- + + package Cycle_Validators is + Invalid_Cycle : exception; + -- Exception raised when the library graph contains an invalid cycle + + procedure Validate_Cycles (G : Library_Graph); + -- Ensure that all cycles of library graph G meet the following + -- requirements: + -- + -- * Are of proper kind + -- * Have enough edges to form a circuit + -- * No edge is repeated + -- + -- Diagnose issues and raise Invalid_Cycle if this is not the case. + + end Cycle_Validators; + ---------------------------------- -- Elaboration_Order_Validators -- ---------------------------------- diff --git a/gcc/ada/bindo-writers.adb b/gcc/ada/bindo-writers.adb index 7450c15..1fcfb11 100644 --- a/gcc/ada/bindo-writers.adb +++ b/gcc/ada/bindo-writers.adb @@ -23,12 +23,15 @@ -- -- ------------------------------------------------------------------------------ -with Debug; use Debug; -with Fname; use Fname; -with Opt; use Opt; -with Output; use Output; +with Binderr; use Binderr; +with Butil; use Butil; +with Debug; use Debug; +with Fname; use Fname; +with Opt; use Opt; +with Output; use Output; -with Bindo.Units; use Bindo.Units; +with Bindo.Units; +use Bindo.Units; with GNAT; use GNAT; with GNAT.Graphs; use GNAT.Graphs; @@ -124,26 +127,27 @@ package body Bindo.Writers is -------------------------------- procedure Write_Invocation_Construct (IC_Id : Invocation_Construct_Id) is + begin pragma Assert (Present (IC_Id)); - IC_Rec : Invocation_Construct_Record renames - Invocation_Constructs.Table (IC_Id); - - begin Write_Str (" invocation construct (IC_Id_"); Write_Int (Int (IC_Id)); Write_Str (")"); Write_Eol; + Write_Str (" Body_Placement = "); + Write_Str (Body_Placement (IC_Id)'Img); + Write_Eol; + Write_Str (" Kind = "); - Write_Str (IC_Rec.Kind'Img); + Write_Str (Kind (IC_Id)'Img); Write_Eol; - Write_Str (" Placement = "); - Write_Str (IC_Rec.Placement'Img); + Write_Str (" Spec_Placement = "); + Write_Str (Spec_Placement (IC_Id)'Img); Write_Eol; - Write_Invocation_Signature (IC_Rec.Signature); + Write_Invocation_Signature (Signature (IC_Id)); Write_Eol; end Write_Invocation_Construct; @@ -152,20 +156,17 @@ package body Bindo.Writers is ------------------------------- procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id) is + begin pragma Assert (Present (IR_Id)); - IR_Rec : Invocation_Relation_Record renames - Invocation_Relations.Table (IR_Id); - - begin Write_Str (" invocation relation (IR_Id_"); Write_Int (Int (IR_Id)); Write_Str (")"); Write_Eol; - if Present (IR_Rec.Extra) then + if Present (Extra (IR_Id)) then Write_Str (" Extra = "); - Write_Name (IR_Rec.Extra); + Write_Name (Extra (IR_Id)); else Write_Str (" Extra = none"); end if; @@ -174,16 +175,16 @@ package body Bindo.Writers is Write_Str (" Invoker"); Write_Eol; - Write_Invocation_Signature (IR_Rec.Invoker); + Write_Invocation_Signature (Invoker (IR_Id)); Write_Str (" Kind = "); - Write_Str (IR_Rec.Kind'Img); + Write_Str (Kind (IR_Id)'Img); Write_Eol; Write_Str (" Target"); Write_Eol; - Write_Invocation_Signature (IR_Rec.Target); + Write_Invocation_Signature (Target (IR_Id)); Write_Eol; end Write_Invocation_Relation; @@ -192,39 +193,36 @@ package body Bindo.Writers is -------------------------------- procedure Write_Invocation_Signature (IS_Id : Invocation_Signature_Id) is + begin pragma Assert (Present (IS_Id)); - IS_Rec : Invocation_Signature_Record renames - Invocation_Signatures.Table (IS_Id); - - begin Write_Str (" Signature (IS_Id_"); Write_Int (Int (IS_Id)); Write_Str (")"); Write_Eol; Write_Str (" Column = "); - Write_Int (Int (IS_Rec.Column)); + Write_Int (Int (Column (IS_Id))); Write_Eol; Write_Str (" Line = "); - Write_Int (Int (IS_Rec.Line)); + Write_Int (Int (Line (IS_Id))); Write_Eol; - if Present (IS_Rec.Locations) then + if Present (Locations (IS_Id)) then Write_Str (" Locations = "); - Write_Name (IS_Rec.Locations); + Write_Name (Locations (IS_Id)); else Write_Str (" Locations = none"); end if; Write_Eol; Write_Str (" Name = "); - Write_Name (IS_Rec.Name); + Write_Name (Name (IS_Id)); Write_Eol; Write_Str (" Scope = "); - Write_Name (IS_Rec.Scope); + Write_Name (Scope (IS_Id)); Write_Eol; end Write_Invocation_Signature; @@ -275,19 +273,19 @@ package body Bindo.Writers is Write_Int (Int (U_Rec.Last_Invocation_Relation)); Write_Str (")"); Write_Eol; + + Write_Str (" Invocation_Graph_Encoding = "); + Write_Str (Invocation_Graph_Encoding (U_Id)'Img); + Write_Eol; Write_Eol; - for IC_Id in U_Rec.First_Invocation_Construct .. - U_Rec.Last_Invocation_Construct - loop - Write_Invocation_Construct (IC_Id); - end loop; + For_Each_Invocation_Construct + (U_Id => U_Id, + Processor => Write_Invocation_Construct'Access); - for IR_Id in U_Rec.First_Invocation_Relation .. - U_Rec.Last_Invocation_Relation - loop - Write_Invocation_Relation (IR_Id); - end loop; + For_Each_Invocation_Relation + (U_Id => U_Id, + Processor => Write_Invocation_Relation'Access); end Write_Unit; ----------------------- @@ -313,6 +311,320 @@ package body Bindo.Writers is end Write_Unit_Common; end ALI_Writers; + ------------------- + -- Cycle_Writers -- + ------------------- + + package body Cycle_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id); + pragma Inline (Write_Cycle); + -- Write the path of cycle Cycle found in library graph G to standard + -- output. + + procedure Write_Cyclic_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id); + pragma Inline (Write_Cyclic_Edge); + -- Write cyclic edge Edge of library graph G to standard + + ----------- + -- Debug -- + ----------- + + procedure palgc (G : Library_Graph) renames Write_Cycles; + pragma Unreferenced (palgc); + + procedure plgc + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) renames Write_Cycle; + pragma Unreferenced (plgc); + + ----------------- + -- Write_Cycle -- + ----------------- + + procedure Write_Cycle + (G : Library_Graph; + Cycle : Library_Graph_Cycle_Id) + is + Edge : Library_Graph_Edge_Id; + Iter : Edges_Of_Cycle_Iterator; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Cycle)); + + -- Nothing to do when switch -d_P (output cycle paths) is not in + -- effect. + + if not Debug_Flag_Underscore_PP then + return; + end if; + + Write_Str ("cycle (LGC_Id_"); + Write_Int (Int (Cycle)); + Write_Str (")"); + Write_Eol; + + Iter := Iterate_Edges_Of_Cycle (G, Cycle); + while Has_Next (Iter) loop + Next (Iter, Edge); + + Write_Cyclic_Edge (G, Edge); + end loop; + + Write_Eol; + end Write_Cycle; + + ------------------ + -- Write_Cycles -- + ------------------ + + procedure Write_Cycles (G : Library_Graph) is + Cycle : Library_Graph_Cycle_Id; + Iter : All_Cycle_Iterator; + + begin + pragma Assert (Present (G)); + + Iter := Iterate_All_Cycles (G); + while Has_Next (Iter) loop + Next (Iter, Cycle); + + Write_Cycle (G, Cycle); + end loop; + end Write_Cycles; + + ----------------------- + -- Write_Cyclic_Edge -- + ----------------------- + + procedure Write_Cyclic_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, Edge); + Succ : constant Library_Graph_Vertex_Id := Successor (G, Edge); + + begin + Indent_By (Nested_Indentation); + Write_Name (Name (G, Succ)); + Write_Str (" --> "); + Write_Name (Name (G, Pred)); + Write_Str (" "); + + if Is_Elaborate_All_Edge (G, Edge) then + Write_Str ("Elaborate_All edge"); + + elsif Is_Elaborate_Body_Edge (G, Edge) then + Write_Str ("Elaborate_Body edge"); + + elsif Is_Elaborate_Edge (G, Edge) then + Write_Str ("Elaborate edge"); + + elsif Is_Forced_Edge (G, Edge) then + Write_Str ("forced edge"); + + elsif Is_Invocation_Edge (G, Edge) then + Write_Str ("invocation edge"); + + else + pragma Assert (Is_With_Edge (G, Edge)); + + Write_Str ("with edge"); + end if; + + Write_Eol; + end Write_Cyclic_Edge; + end Cycle_Writers; + + ------------------------ + -- Dependency_Writers -- + ------------------------ + + package body Dependency_Writers is + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Dependencies_Of_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id); + pragma Inline (Write_Dependencies_Of_Vertex); + -- Write the dependencies of vertex Vertex of library graph G to + -- standard output. + + procedure Write_Dependency_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id); + pragma Inline (Write_Dependency_Edge); + -- Write the dependency described by edge Edge of library graph G to + -- standard output. + + ------------------------ + -- Write_Dependencies -- + ------------------------ + + procedure Write_Dependencies (G : Library_Graph) is + Use_Formatting : constant Boolean := not Zero_Formatting; + + Iter : Library_Graphs.All_Vertex_Iterator; + Vertex : Library_Graph_Vertex_Id; + + begin + pragma Assert (Present (G)); + + -- Nothing to do when switch -e (output complete list of elaboration + -- order dependencies) is not in effect. + + if not Elab_Dependency_Output then + return; + end if; + + if Use_Formatting then + Write_Eol; + Write_Line ("ELABORATION ORDER DEPENDENCIES"); + Write_Eol; + end if; + + Info_Prefix_Suppress := True; + + Iter := Iterate_All_Vertices (G); + while Has_Next (Iter) loop + Next (Iter, Vertex); + + Write_Dependencies_Of_Vertex (G, Vertex); + end loop; + + Info_Prefix_Suppress := False; + + if Use_Formatting then + Write_Eol; + end if; + end Write_Dependencies; + + ---------------------------------- + -- Write_Dependencies_Of_Vertex -- + ---------------------------------- + + procedure Write_Dependencies_Of_Vertex + (G : Library_Graph; + Vertex : Library_Graph_Vertex_Id) + is + Edge : Library_Graph_Edge_Id; + Iter : Edges_To_Successors_Iterator; + + begin + pragma Assert (Present (G)); + pragma Assert (Present (Vertex)); + + -- Nothing to do for internal and predefined units + + if Is_Internal_Unit (G, Vertex) + or else Is_Predefined_Unit (G, Vertex) + then + return; + end if; + + Iter := Iterate_Edges_To_Successors (G, Vertex); + while Has_Next (Iter) loop + Next (Iter, Edge); + + Write_Dependency_Edge (G, Edge); + end loop; + end Write_Dependencies_Of_Vertex; + + --------------------------- + -- Write_Dependency_Edge -- + --------------------------- + + procedure Write_Dependency_Edge + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) + is + pragma Assert (Present (G)); + pragma Assert (Present (Edge)); + + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, Edge); + Succ : constant Library_Graph_Vertex_Id := Successor (G, Edge); + + begin + -- Nothing to do for internal and predefined units + + if Is_Internal_Unit (G, Succ) + or else Is_Predefined_Unit (G, Succ) + then + return; + end if; + + Error_Msg_Unit_1 := Name (G, Pred); + Error_Msg_Unit_2 := Name (G, Succ); + Error_Msg_Output + (Msg => " unit $ must be elaborated before unit $", + Info => True); + + Error_Msg_Unit_1 := Name (G, Succ); + Error_Msg_Unit_2 := Name (G, Pred); + + if Is_Elaborate_All_Edge (G, Edge) then + Error_Msg_Output + (Msg => + " reason: unit $ has with clause and pragma " + & "Elaborate_All for unit $", + Info => True); + + elsif Is_Elaborate_Body_Edge (G, Edge) then + Error_Msg_Output + (Msg => " reason: unit $ has with clause for unit $", + Info => True); + + elsif Is_Elaborate_Edge (G, Edge) then + Error_Msg_Output + (Msg => + " reason: unit $ has with clause and pragma Elaborate " + & "for unit $", + Info => True); + + elsif Is_Forced_Edge (G, Edge) then + Error_Msg_Output + (Msg => + " reason: unit $ has a dependency on unit $ forced by -f " + & "switch", + Info => True); + + elsif Is_Invocation_Edge (G, Edge) then + Error_Msg_Output + (Msg => + " reason: unit $ invokes a construct of unit $ at " + & "elaboration time", + Info => True); + + elsif Is_Spec_Before_Body_Edge (G, Edge) then + Error_Msg_Output + (Msg => " reason: spec must be elaborated before body", + Info => True); + + else + pragma Assert (Is_With_Edge (G, Edge)); + + Error_Msg_Output + (Msg => " reason: unit $ has with clause for unit $", + Info => True); + end if; + end Write_Dependency_Edge; + end Dependency_Writers; + ------------------------------- -- Elaboration_Order_Writers -- ------------------------------- @@ -336,25 +648,27 @@ package body Bindo.Writers is ----------------------------- procedure Write_Elaboration_Order (Order : Unit_Id_Table) is + Use_Formatting : constant Boolean := not Zero_Formatting; + begin - -- Nothing to do when switch -d_O (output elaboration order) is not - -- in effect. + -- Nothing to do when switch -l (output chosen elaboration order) is + -- not in effect. - if not Debug_Flag_Underscore_OO then + if not Elab_Order_Output then return; end if; - Write_Str ("Elaboration Order"); - Write_Eol; - Write_Eol; + if Use_Formatting then + Write_Eol; + Write_Str ("ELABORATION ORDER"); + Write_Eol; + end if; Write_Units (Order); - Write_Eol; - Write_Str ("Elaboration Order end"); - Write_Eol; - - Write_Eol; + if Use_Formatting then + Write_Eol; + end if; end Write_Elaboration_Order; ---------------- @@ -362,13 +676,16 @@ package body Bindo.Writers is ---------------- procedure Write_Unit (U_Id : Unit_Id) is + Use_Formatting : constant Boolean := not Zero_Formatting; + begin pragma Assert (Present (U_Id)); - Write_Str ("unit (U_Id_"); - Write_Int (Int (U_Id)); - Write_Str (") name = "); - Write_Name (Name (U_Id)); + if Use_Formatting then + Write_Str (" "); + end if; + + Write_Unit_Name (Name (U_Id)); Write_Eol; end Write_Unit; @@ -416,22 +733,23 @@ package body Bindo.Writers is -- Write all elaboration roots of invocation graph G to standard output procedure Write_Invocation_Graph_Edge - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id); + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id); pragma Inline (Write_Invocation_Graph_Edge); - -- Write edge IGE_Id of invocation graph G to standard output + -- Write edge Edge of invocation graph G to standard output procedure Write_Invocation_Graph_Edges (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id); + Vertex : Invocation_Graph_Vertex_Id); pragma Inline (Write_Invocation_Graph_Edges); - -- Write all edges of invocation graph G to standard output + -- Write all edges to targets of vertex Vertex of invocation graph G to + -- standard output. procedure Write_Invocation_Graph_Vertex (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id); + Vertex : Invocation_Graph_Vertex_Id); pragma Inline (Write_Invocation_Graph_Vertex); - -- Write vertex IGV_Id of invocation graph G to standard output + -- Write vertex Vertex of invocation graph G to standard output procedure Write_Invocation_Graph_Vertices (G : Invocation_Graph); pragma Inline (Write_Invocation_Graph_Vertices); @@ -447,14 +765,13 @@ package body Bindo.Writers is ----------- procedure pige - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) - renames Write_Invocation_Graph_Edge; + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) renames Write_Invocation_Graph_Edge; pragma Unreferenced (pige); procedure pigv (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) + Vertex : Invocation_Graph_Vertex_Id) renames Write_Invocation_Graph_Vertex; pragma Unreferenced (pigv); @@ -498,7 +815,6 @@ package body Bindo.Writers is Iter := Iterate_Elaboration_Roots (G); while Has_Next (Iter) loop Next (Iter, Root); - pragma Assert (Present (Root)); Write_Elaboration_Root (G, Root); end loop; @@ -541,24 +857,22 @@ package body Bindo.Writers is --------------------------------- procedure Write_Invocation_Graph_Edge - (G : Invocation_Graph; - IGE_Id : Invocation_Graph_Edge_Id) + (G : Invocation_Graph; + Edge : Invocation_Graph_Edge_Id) is pragma Assert (Present (G)); - pragma Assert (Present (IGE_Id)); + pragma Assert (Present (Edge)); - Targ : constant Invocation_Graph_Vertex_Id := Target (G, IGE_Id); - - pragma Assert (Present (Targ)); + Targ : constant Invocation_Graph_Vertex_Id := Target (G, Edge); begin Write_Str (" invocation graph edge (IGE_Id_"); - Write_Int (Int (IGE_Id)); + Write_Int (Int (Edge)); Write_Str (")"); Write_Eol; Write_Str (" Relation (IR_Id_"); - Write_Int (Int (Relation (G, IGE_Id))); + Write_Int (Int (Relation (G, Edge))); Write_Str (")"); Write_Eol; @@ -577,16 +891,16 @@ package body Bindo.Writers is procedure Write_Invocation_Graph_Edges (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) + Vertex : Invocation_Graph_Vertex_Id) is pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); Num_Of_Edges : constant Natural := - Number_Of_Edges_To_Targets (G, IGV_Id); + Number_Of_Edges_To_Targets (G, Vertex); - IGE_Id : Invocation_Graph_Edge_Id; - Iter : Invocation_Graphs.Edges_To_Targets_Iterator; + Edge : Invocation_Graph_Edge_Id; + Iter : Invocation_Graphs.Edges_To_Targets_Iterator; begin Write_Str (" Edges to targets: "); @@ -594,12 +908,11 @@ package body Bindo.Writers is Write_Eol; if Num_Of_Edges > 0 then - Iter := Iterate_Edges_To_Targets (G, IGV_Id); + Iter := Iterate_Edges_To_Targets (G, Vertex); while Has_Next (Iter) loop - Next (Iter, IGE_Id); - pragma Assert (Present (IGE_Id)); + Next (Iter, Edge); - Write_Invocation_Graph_Edge (G, IGE_Id); + Write_Invocation_Graph_Edge (G, Edge); end loop; else Write_Eol; @@ -612,29 +925,34 @@ package body Bindo.Writers is procedure Write_Invocation_Graph_Vertex (G : Invocation_Graph; - IGV_Id : Invocation_Graph_Vertex_Id) + Vertex : Invocation_Graph_Vertex_Id) is begin pragma Assert (Present (G)); - pragma Assert (Present (IGV_Id)); + pragma Assert (Present (Vertex)); Write_Str ("invocation graph vertex (IGV_Id_"); - Write_Int (Int (IGV_Id)); + Write_Int (Int (Vertex)); Write_Str (") name = "); - Write_Name (Name (G, IGV_Id)); + Write_Name (Name (G, Vertex)); + Write_Eol; + + Write_Str (" Body_Vertex (LGV_Id_"); + Write_Int (Int (Body_Vertex (G, Vertex))); + Write_Str (")"); Write_Eol; Write_Str (" Construct (IC_Id_"); - Write_Int (Int (Construct (G, IGV_Id))); + Write_Int (Int (Construct (G, Vertex))); Write_Str (")"); Write_Eol; - Write_Str (" Lib_Vertex (LGV_Id_"); - Write_Int (Int (Lib_Vertex (G, IGV_Id))); + Write_Str (" Spec_Vertex (LGV_Id_"); + Write_Int (Int (Spec_Vertex (G, Vertex))); Write_Str (")"); Write_Eol; - Write_Invocation_Graph_Edges (G, IGV_Id); + Write_Invocation_Graph_Edges (G, Vertex); end Write_Invocation_Graph_Vertex; ------------------------------------- @@ -642,18 +960,17 @@ package body Bindo.Writers is ------------------------------------- procedure Write_Invocation_Graph_Vertices (G : Invocation_Graph) is - IGV_Id : Invocation_Graph_Vertex_Id; Iter : Invocation_Graphs.All_Vertex_Iterator; + Vertex : Invocation_Graph_Vertex_Id; begin pragma Assert (Present (G)); Iter := Iterate_All_Vertices (G); while Has_Next (Iter) loop - Next (Iter, IGV_Id); - pragma Assert (Present (IGV_Id)); + Next (Iter, Vertex); - Write_Invocation_Graph_Vertex (G, IGV_Id); + Write_Invocation_Graph_Vertex (G, Vertex); end loop; end Write_Invocation_Graph_Vertices; @@ -714,27 +1031,27 @@ package body Bindo.Writers is -- output. procedure Write_Components (G : Library_Graph); - pragma Inline (Write_Components); + pragma Inline (Write_Component); -- Write all components of library graph G to standard output procedure Write_Edges_To_Successors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id); + Vertex : Library_Graph_Vertex_Id); pragma Inline (Write_Edges_To_Successors); - -- Write all edges to successors of predecessor LGV_Id of library graph + -- Write all edges to successors of predecessor Vertex of library graph -- G to standard output. procedure Write_Library_Graph_Edge - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id); + (G : Library_Graph; + Edge : Library_Graph_Edge_Id); pragma Inline (Write_Library_Graph_Edge); - -- Write edge LGE_Id of library graph G to standard output + -- Write edge Edge of library graph G to standard output procedure Write_Library_Graph_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id); + Vertex : Library_Graph_Vertex_Id); pragma Inline (Write_Library_Graph_Vertex); - -- Write vertex LGV_Id of library graph G to standard output + -- Write vertex Vertex of library graph G to standard output procedure Write_Library_Graph_Vertices (G : Library_Graph); pragma Inline (Write_Library_Graph_Vertices); @@ -755,13 +1072,13 @@ package body Bindo.Writers is pragma Unreferenced (pc); procedure plge - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) renames Write_Library_Graph_Edge; + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) renames Write_Library_Graph_Edge; pragma Unreferenced (plge); procedure plgv (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) renames Write_Library_Graph_Vertex; + Vertex : Library_Graph_Vertex_Id) renames Write_Library_Graph_Vertex; pragma Unreferenced (plgv); --------------------- @@ -781,11 +1098,17 @@ package body Bindo.Writers is Write_Str (")"); Write_Eol; - Write_Str (" Pending_Predecessors = "); - Write_Int (Int (Pending_Predecessors (G, Comp))); + Write_Str (" Pending_Strong_Predecessors = "); + Write_Int (Int (Pending_Strong_Predecessors (G, Comp))); + Write_Eol; + + Write_Str (" Pending_Weak_Predecessors = "); + Write_Int (Int (Pending_Weak_Predecessors (G, Comp))); Write_Eol; Write_Component_Vertices (G, Comp); + + Write_Eol; end Write_Component; ------------------------------ @@ -796,26 +1119,34 @@ package body Bindo.Writers is (G : Library_Graph; Comp : Component_Id) is - Iter : Component_Vertex_Iterator; - LGV_Id : Library_Graph_Vertex_Id; - - begin pragma Assert (Present (G)); pragma Assert (Present (Comp)); - Iter := Iterate_Component_Vertices (G, Comp); - while Has_Next (Iter) loop - Next (Iter, LGV_Id); - pragma Assert (Present (LGV_Id)); + Num_Of_Vertices : constant Natural := + Number_Of_Component_Vertices (G, Comp); - Write_Str (" library graph vertex (LGV_Id_"); - Write_Int (Int (LGV_Id)); - Write_Str (") name = "); - Write_Name (Name (G, LGV_Id)); - Write_Eol; - end loop; + Iter : Component_Vertex_Iterator; + Vertex : Library_Graph_Vertex_Id; + begin + Write_Str (" Vertices: "); + Write_Int (Int (Num_Of_Vertices)); Write_Eol; + + if Num_Of_Vertices > 0 then + Iter := Iterate_Component_Vertices (G, Comp); + while Has_Next (Iter) loop + Next (Iter, Vertex); + + Write_Str (" library graph vertex (LGV_Id_"); + Write_Int (Int (Vertex)); + Write_Str (") name = "); + Write_Name (Name (G, Vertex)); + Write_Eol; + end loop; + else + Write_Eol; + end if; end Write_Component_Vertices; ---------------------- @@ -831,17 +1162,36 @@ package body Bindo.Writers is Iter : Component_Iterator; begin + -- Nothing to do when switch -d_L (output library item graph) is not + -- in effect. + + if not Debug_Flag_Underscore_LL then + return; + end if; + + Write_Str ("Library Graph components"); + Write_Eol; + Write_Eol; + if Num_Of_Comps > 0 then + Write_Str ("Components: "); + Write_Num (Int (Num_Of_Comps)); + Write_Eol; + Iter := Iterate_Components (G); while Has_Next (Iter) loop Next (Iter, Comp); - pragma Assert (Present (Comp)); Write_Component (G, Comp); end loop; else Write_Eol; end if; + + Write_Str ("Library Graph components end"); + Write_Eol; + + Write_Eol; end Write_Components; ------------------------------- @@ -850,16 +1200,16 @@ package body Bindo.Writers is procedure Write_Edges_To_Successors (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id) is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); Num_Of_Edges : constant Natural := - Number_Of_Edges_To_Successors (G, LGV_Id); + Number_Of_Edges_To_Successors (G, Vertex); - Iter : Edges_To_Successors_Iterator; - LGE_Id : Library_Graph_Edge_Id; + Edge : Library_Graph_Edge_Id; + Iter : Edges_To_Successors_Iterator; begin Write_Str (" Edges to successors: "); @@ -867,12 +1217,11 @@ package body Bindo.Writers is Write_Eol; if Num_Of_Edges > 0 then - Iter := Iterate_Edges_To_Successors (G, LGV_Id); + Iter := Iterate_Edges_To_Successors (G, Vertex); while Has_Next (Iter) loop - Next (Iter, LGE_Id); - pragma Assert (Present (LGE_Id)); + Next (Iter, Edge); - Write_Library_Graph_Edge (G, LGE_Id); + Write_Library_Graph_Edge (G, Edge); end loop; else Write_Eol; @@ -913,26 +1262,23 @@ package body Bindo.Writers is ------------------------------ procedure Write_Library_Graph_Edge - (G : Library_Graph; - LGE_Id : Library_Graph_Edge_Id) + (G : Library_Graph; + Edge : Library_Graph_Edge_Id) is pragma Assert (Present (G)); - pragma Assert (Present (LGE_Id)); - - Pred : constant Library_Graph_Vertex_Id := Predecessor (G, LGE_Id); - Succ : constant Library_Graph_Vertex_Id := Successor (G, LGE_Id); + pragma Assert (Present (Edge)); - pragma Assert (Present (Pred)); - pragma Assert (Present (Succ)); + Pred : constant Library_Graph_Vertex_Id := Predecessor (G, Edge); + Succ : constant Library_Graph_Vertex_Id := Successor (G, Edge); begin Write_Str (" library graph edge (LGE_Id_"); - Write_Int (Int (LGE_Id)); + Write_Int (Int (Edge)); Write_Str (")"); Write_Eol; Write_Str (" Kind = "); - Write_Str (Kind (G, LGE_Id)'Img); + Write_Str (Kind (G, Edge)'Img); Write_Eol; Write_Str (" Predecessor (LGV_Id_"); @@ -956,22 +1302,20 @@ package body Bindo.Writers is procedure Write_Library_Graph_Vertex (G : Library_Graph; - LGV_Id : Library_Graph_Vertex_Id) + Vertex : Library_Graph_Vertex_Id) is pragma Assert (Present (G)); - pragma Assert (Present (LGV_Id)); + pragma Assert (Present (Vertex)); Item : constant Library_Graph_Vertex_Id := - Corresponding_Item (G, LGV_Id); - U_Id : constant Unit_Id := Unit (G, LGV_Id); - - pragma Assert (Present (U_Id)); + Corresponding_Item (G, Vertex); + U_Id : constant Unit_Id := Unit (G, Vertex); begin Write_Str ("library graph vertex (LGV_Id_"); - Write_Int (Int (LGV_Id)); + Write_Int (Int (Vertex)); Write_Str (") name = "); - Write_Name (Name (G, LGV_Id)); + Write_Name (Name (G, Vertex)); Write_Eol; if Present (Item) then @@ -986,19 +1330,23 @@ package body Bindo.Writers is Write_Eol; Write_Str (" In_Elaboration_Order = "); - if In_Elaboration_Order (G, LGV_Id) then + if In_Elaboration_Order (G, Vertex) then Write_Str ("True"); else Write_Str ("False"); end if; Write_Eol; - Write_Str (" Pending_Predecessors = "); - Write_Int (Int (Pending_Predecessors (G, LGV_Id))); + Write_Str (" Pending_Strong_Predecessors = "); + Write_Int (Int (Pending_Strong_Predecessors (G, Vertex))); + Write_Eol; + + Write_Str (" Pending_Weak_Predecessors = "); + Write_Int (Int (Pending_Weak_Predecessors (G, Vertex))); Write_Eol; Write_Str (" Component (Comp_Id_"); - Write_Int (Int (Component (G, LGV_Id))); + Write_Int (Int (Component (G, Vertex))); Write_Str (")"); Write_Eol; @@ -1008,7 +1356,7 @@ package body Bindo.Writers is Write_Name (Name (U_Id)); Write_Eol; - Write_Edges_To_Successors (G, LGV_Id); + Write_Edges_To_Successors (G, Vertex); end Write_Library_Graph_Vertex; ---------------------------------- @@ -1017,17 +1365,16 @@ package body Bindo.Writers is procedure Write_Library_Graph_Vertices (G : Library_Graph) is Iter : Library_Graphs.All_Vertex_Iterator; - LGV_Id : Library_Graph_Vertex_Id; + Vertex : Library_Graph_Vertex_Id; begin pragma Assert (Present (G)); Iter := Iterate_All_Vertices (G); while Has_Next (Iter) loop - Next (Iter, LGV_Id); - pragma Assert (Present (LGV_Id)); + Next (Iter, Vertex); - Write_Library_Graph_Vertex (G, LGV_Id); + Write_Library_Graph_Vertex (G, Vertex); end loop; end Write_Library_Graph_Vertices; @@ -1062,6 +1409,94 @@ package body Bindo.Writers is end Write_Statistics; end Library_Graph_Writers; + ------------------- + -- Phase_Writers -- + ------------------- + + package body Phase_Writers is + + subtype Phase_Message is String (1 .. 32); + + -- The following table contains the phase-specific messages for phase + -- completion. + + End_Messages : constant array (Elaboration_Phase) of Phase_Message := + (Component_Discovery => "components discovered. ", + Cycle_Diagnostics => "cycle diagnosed. ", + Cycle_Discovery => "cycles discovered. ", + Cycle_Validation => "cycles validated. ", + Elaboration_Order_Validation => "elaboration order validated. ", + Invocation_Graph_Construction => "invocation graph constructed. ", + Invocation_Graph_Validation => "invocation graph validated. ", + Library_Graph_Augmentation => "library graph augmented. ", + Library_Graph_Construction => "library graph constructed. ", + Library_Graph_Elaboration => "library graph elaborated. ", + Library_Graph_Validation => "library graph validated. ", + Unit_Collection => "units collected. ", + Unit_Elaboration => "units elaborated. "); + + -- The following table contains the phase-specific messages for phase + -- commencement. + + Start_Messages : constant array (Elaboration_Phase) of Phase_Message := + (Component_Discovery => "discovering components... ", + Cycle_Diagnostics => "diagnosing cycle... ", + Cycle_Discovery => "discovering cycles... ", + Cycle_Validation => "validating cycles... ", + Elaboration_Order_Validation => "validating elaboration order... ", + Invocation_Graph_Construction => "constructing invocation graph...", + Invocation_Graph_Validation => "validating invocation graph... ", + Library_Graph_Augmentation => "augmenting library graph... ", + Library_Graph_Construction => "constructing library graph... ", + Library_Graph_Elaboration => "elaborating library graph... ", + Library_Graph_Validation => "validating library graph... ", + Unit_Collection => "collecting units... ", + Unit_Elaboration => "elaborating units... "); + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Write_Phase_Message (Msg : Phase_Message); + pragma Inline (Write_Phase_Message); + -- Write elaboration phase-related message Msg to standard output + + --------------- + -- End_Phase -- + --------------- + + procedure End_Phase (Phase : Elaboration_Phase) is + begin + Write_Phase_Message (End_Messages (Phase)); + end End_Phase; + + ----------------- + -- Start_Phase -- + ----------------- + + procedure Start_Phase (Phase : Elaboration_Phase) is + begin + Write_Phase_Message (Start_Messages (Phase)); + end Start_Phase; + + ------------------------- + -- Write_Phase_Message -- + ------------------------- + + procedure Write_Phase_Message (Msg : Phase_Message) is + begin + -- Nothing to do when switch -d_S (output elaboration order status) + -- is not in effect. + + if not Debug_Flag_Underscore_SS then + return; + end if; + + Write_Str (Msg); + Write_Eol; + end Write_Phase_Message; + end Phase_Writers; + -------------------------- -- Unit_Closure_Writers -- -------------------------- @@ -1071,11 +1506,11 @@ package body Bindo.Writers is pragma Inline (Hash_File_Name); -- Obtain the hash value of key Nam - package FS is new Membership_Sets + package File_Name_Tables is new Membership_Sets (Element_Type => File_Name_Type, "=" => "=", Hash => Hash_File_Name); - use FS; + use File_Name_Tables; ----------------------- -- Local subprograms -- @@ -1128,10 +1563,12 @@ package body Bindo.Writers is --------------------- procedure Write_File_Name (Nam : File_Name_Type) is + Use_Formatting : constant Boolean := not Zero_Formatting; + begin pragma Assert (Present (Nam)); - if not Zero_Formatting then + if Use_Formatting then Write_Str (" "); end if; @@ -1193,6 +1630,8 @@ package body Bindo.Writers is ------------------------ procedure Write_Unit_Closure (Order : Unit_Id_Table) is + Use_Formatting : constant Boolean := not Zero_Formatting; + Set : Membership_Set; begin @@ -1203,7 +1642,7 @@ package body Bindo.Writers is return; end if; - if not Zero_Formatting then + if Use_Formatting then Write_Eol; Write_Line ("REFERENCED SOURCES"); end if; @@ -1217,7 +1656,7 @@ package body Bindo.Writers is Destroy (Set); - if not Zero_Formatting then + if Use_Formatting then Write_Eol; end if; end Write_Unit_Closure; @@ -1290,7 +1729,7 @@ package body Bindo.Writers is is function Digits_Indentation return Indentation_Level; pragma Inline (Digits_Indentation); - -- Determine the level of indentation the number requies in order to + -- Determine the level of indentation the number requires in order to -- be right-justified by Val_Indent. ------------------------ diff --git a/gcc/ada/bindo-writers.ads b/gcc/ada/bindo-writers.ads index 9ed598e..66483d0 100644 --- a/gcc/ada/bindo-writers.ads +++ b/gcc/ada/bindo-writers.ads @@ -81,6 +81,27 @@ package Bindo.Writers is end ALI_Writers; + ------------------- + -- Cycle_Writers -- + ------------------- + + package Cycle_Writers is + procedure Write_Cycles (G : Library_Graph); + -- Write all cycles of library graph G to standard output + + end Cycle_Writers; + + ------------------------ + -- Dependency_Writers -- + ------------------------ + + package Dependency_Writers is + procedure Write_Dependencies (G : Library_Graph); + -- Write all elaboration dependencies of the units represented by + -- vertices of library graph G. + + end Dependency_Writers; + ------------------------------- -- Elaboration_Order_Writers -- ------------------------------- @@ -111,6 +132,23 @@ package Bindo.Writers is end Library_Graph_Writers; + ------------------- + -- Phase_Writers -- + ------------------- + + package Phase_Writers is + procedure End_Phase (Phase : Elaboration_Phase); + pragma Inline (End_Phase); + -- Write the end message associated with elaboration phase Phase to + -- standard output. + + procedure Start_Phase (Phase : Elaboration_Phase); + pragma Inline (Start_Phase); + -- Write the start message associated with elaboration phase Phase to + -- standard output. + + end Phase_Writers; + -------------------------- -- Unit_Closure_Writers -- -------------------------- diff --git a/gcc/ada/bindo.adb b/gcc/ada/bindo.adb index 7d26476..249ce972 100644 --- a/gcc/ada/bindo.adb +++ b/gcc/ada/bindo.adb @@ -23,16 +23,19 @@ -- -- ------------------------------------------------------------------------------ +with Binde; +with Opt; use Opt; + with Bindo.Elaborators; -use Bindo.Elaborators.Invocation_And_Library_Graph_Elaborators; +use Bindo.Elaborators; package body Bindo is --------------------------------- - -- Elaboration order mechanism -- + -- Elaboration-order mechanism -- --------------------------------- - -- The elaboration order (EO) mechanism implemented in this unit and its + -- The elaboration-order (EO) mechanism implemented in this unit and its -- children has the following objectives: -- -- * Find an ordering of all library items (historically referred to as @@ -47,30 +50,44 @@ package body Bindo is -- - The flow of execution at elaboration time. -- -- - Additional dependencies between units supplied to the binder by - -- means of a file. + -- means of a forced-elaboration-order file. + -- + -- The high-level idea empoyed by the EO mechanism is to construct two + -- graphs and use the information they represent to find an ordering of + -- all units. -- - -- The high-level idea is to construct two graphs: + -- The invocation graph represents the flow of execution at elaboration + -- time. -- - -- - Invocation graph - Models the flow of execution at elaboration - -- time. + -- The library graph captures the dependencies between units expressed + -- by with clause and elaboration-related pragmas. The library graph is + -- further augmented with additional information from the invocation + -- graph by exploring the execution paths from a unit with elaboration + -- code to other external units. -- - -- - Library graph - Represents with clause and pragma dependencies - -- between units. + -- The strongly connected components of the library graph are computed. -- - -- The library graph is further augmented with additional information - -- from the invocation graph by exploring the execution paths from a - -- unit with elaboration code to other external units. All strongly - -- connected components of the library graph are discovered. Finally, - -- the order is obtained via a topological sort-like algorithm which - -- attempts to order available units while enabling other units to be + -- The order is obtained using a topological sort-like algorithm which + -- traverses the library graph and its strongly connected components in + -- an attempt to order available units while enabling other units to be -- ordered. -- -- * Diagnose elaboration circularities between units -- - -- The library graph may contain at least one cycle, in which case no - -- ordering is possible. + -- An elaboration circularity arises when either + -- + -- - At least one unit cannot be ordered, or + -- + -- - All units can be ordered, but an edge with an Elaborate_All + -- pragma links two vertices within the same component of the + -- library graph. + -- + -- The library graph is traversed to discover, collect, and sort all + -- cycles that hinder the elaboration order. -- - -- ??? more on this later + -- The most important cycle is diagnosed by describing its effects on + -- the elaboration order and listing all units comprising the circuit. + -- Various suggestions on how to break the cycle are offered. ----------------- -- Terminology -- @@ -78,6 +95,14 @@ package body Bindo is -- * Component - A strongly connected component of a graph. -- + -- * Elaborable component - A component that is not waiting on other + -- components to be elaborated. + -- + -- * Elaborable vertex - A vertex that is not waiting on strong and weak + -- predecessors, and whose component is elaborable. + -- + -- * Elaboration circularity - A cycle involving units from the bind. + -- -- * Elaboration root - A special invocation construct which denotes the -- elaboration procedure of a unit. -- @@ -117,8 +142,23 @@ package body Bindo is -- * Pending predecessor - A vertex that must be elaborated before another -- vertex can be elaborated. -- + -- * Strong edge - A non-invocation library graph edge. Strong edges + -- represent the language-defined relations between units. + -- + -- * Strong predecessor - A library graph vertex reachable via a strong + -- edge. + -- -- * Target - The destination construct of an invocation relation (the -- generic, subprogram, or task type). + -- + -- * Weak edge - An invocation library graph edge. Weak edges represent + -- the speculative flow of execution at elaboration time, which may or + -- may not take place. + -- + -- * Weak predecessor - A library graph vertex reachable via a weak edge. + -- + -- * Weakly elaborable vertex - A vertex that is waiting solely on weak + -- predecessors to be elaborated, and whose component is elaborable. ------------------ -- Architecture -- @@ -162,7 +202,11 @@ package body Bindo is -- | -- +------ | -------------- Diagnostics phase -------------------------+ -- | | | - -- | +--> ??? more on this later | + -- | +--> Find_Cycles | + -- | +--> Validate_Cycles | + -- | +--> Write_Cycles | + -- | | | + -- | +--> Diagnose_Cycle / Diagnose_All_Cycles | -- | | -- +-------------------------------------------------------------------+ @@ -210,7 +254,7 @@ package body Bindo is -- bodies as single vertices. -- -- * Try to order as many vertices of the library graph as possible by - -- peforming a topological sort based on the pending predecessors of + -- performing a topological sort based on the pending predecessors of -- vertices across all components and within a single component. -- -- * Validate the consistency of the order, only when switch -d_V is in @@ -225,17 +269,74 @@ package body Bindo is -- Diagnostics phase -- ----------------------- - -- ??? more on this later + -- The Diagnostics phase has the following objectives: + -- + -- * Discover, save, and sort all cycles in the library graph. The cycles + -- are sorted based on the following heuristics: + -- + -- - A cycle with higher precedence is preferred. + -- + -- - A cycle with fewer invocation edges is preferred. + -- + -- - A cycle with a shorter length is preferred. + -- + -- * Validate the consistency of cycles, only when switch -d_V is in + -- effect. + -- + -- * Write the contents of all cycles in human-readable form to standard + -- output when switch -d_O is in effect. + -- + -- * Diagnose the most important cycle, or all cycles when switch -d_C is + -- in effect. The diagnostic consists of: + -- + -- - The reason for the existence of the cycle, along with the unit + -- whose elaboration cannot be guaranteed. + -- + -- - A detailed traceback of the cycle, showcasing the transition + -- between units, along with any other elaboration-order-related + -- information. + -- + -- - A set of suggestions on how to break the cycle considering the + -- the edges comprising the circuit, the elaboration model used to + -- compile the units, the availability of invocation information, + -- and the state of various relevant switches. -------------- -- Switches -- -------------- + -- -d_a Ignore the effects of pragma Elaborate_All + -- + -- GNATbind creates a regular with edge instead of an Elaborate_All + -- edge in the library graph, thus eliminating the effects of the + -- pragma. + -- + -- -d_b Ignore the effects of pragma Elaborate_Body + -- + -- GNATbind treats a spec and body pair as decoupled. + -- + -- -d_e Ignore the effects of pragma Elaborate + -- + -- GNATbind creates a regular with edge instead of an Elaborate edge + -- in the library graph, thus eliminating the effects of the pragma. + -- In addition, GNATbind does not create an edge to the body of the + -- pragma argument. + -- + -- -d_t Output cycle-detection trace information + -- + -- GNATbind outputs trace information on cycle-detection activities + -- to standard output. + -- -- -d_A Output ALI invocation tables -- -- GNATbind outputs the contents of ALI table Invocation_Constructs -- and Invocation_Edges in textual format to standard output. -- + -- -d_C Diagnose all cycles + -- + -- GNATbind outputs diagnostics for all unique cycles in the bind, + -- rather than just the most important one. + -- -- -d_I Output invocation graph -- -- GNATbind outputs the invocation graph in text format to standard @@ -246,31 +347,148 @@ package body Bindo is -- GNATbind outputs the library graph in textual format to standard -- output. -- - -- -d_N New bindo order + -- -d_P Output cycle paths -- - -- GNATbind utilizes the new bindo elaboration order + -- GNATbind outputs the cycle paths in text format to standard output -- - -- -d_O Output elaboration order + -- -d_S Output elaboration-order status information -- - -- GNATbind outputs the elaboration order in text format to standard + -- GNATbind outputs trace information concerning the status of its + -- various phases to standard output. + -- + -- -d_T Output elaboration-order trace information + -- + -- GNATbind outputs trace information on elaboration-order detection + -- activities to standard output. + -- + -- -d_V Validate bindo cycles, graphs, and order + -- + -- GNATbind validates the invocation graph, library graph along with + -- its cycles, and elaboration order by detecting inconsistencies and + -- producing error reports. + -- + -- -e Output complete list of elaboration-order dependencies + -- + -- GNATbind outputs the dependencies between units to standard -- output. -- - -- -d_T Output elaboration order trace information + -- -f Force elaboration order from given file -- - -- GNATbind outputs trace information on elaboration order activities - -- to standard output. + -- GNATbind applies an additional set of edges to the library graph. + -- The edges are read from a file specified by the argument of the + -- flag. + -- + -- -H Legacy elaboration-order model enabled + -- + -- GNATbind uses the library-graph and heuristics-based elaboration- + -- order model. + -- + -- -l Output chosen elaboration order + -- + -- GNATbind outputs the elaboration order in text format to standard + -- output. -- - -- -d_V Validate bindo graphs and order + -- -p Pessimistic (worst-case) elaboration order -- - -- GNATbind validates the invocation graph, library graph, SCC graph - -- and elaboration order by detecting inconsistencies and producing - -- error reports. + -- This switch is not used in Bindo and its children. ---------------------------------------- - -- Debugging elaboration order issues -- + -- Debugging elaboration-order issues -- ---------------------------------------- - -- ??? more on this later + -- Prior to debugging elaboration-order-related issues, enable all relevant + -- debug flags to collect as much information as possible. Depending on the + -- number of files in the bind, Bindo may emit anywhere between several MBs + -- to several hundred MBs of data to standard output. The switches are: + -- + -- -d_A -d_C -d_I -d_L -d_P -d_t -d_T -d_V + -- + -- Bindo offers several debugging routines that can be invoked from gdb. + -- Those are defined in the body of Bindo.Writers, in sections denoted by + -- header Debug. For quick reference, the routines are: + -- + -- palgc -- print all library-graph cycles + -- pau -- print all units + -- pc -- print component + -- pige -- print invocation-graph edge + -- pigv -- print invocation-graph vertex + -- plgc -- print library-graph cycle + -- plge -- print library-graph edge + -- plgv -- print library-graph vertex + -- pu -- print units + -- + -- * Apparent infinite loop + -- + -- The elaboration order mechanism appears to be stuck in an infinite + -- loop. Use switch -d_S to output the status of each elaboration phase. + -- + -- * Invalid elaboration order + -- + -- The elaboration order is invalid when: + -- + -- - A unit that requires elaboration is missing from the order + -- - A unit that does not require elaboration is present in the order + -- + -- Examine the output of the elaboration algorithm available via switch + -- -d_T to determine how the related units were included in or excluded + -- from the order. Determine whether the library graph contains all the + -- relevant edges for those units. + -- + -- Units and routines of interest: + -- Bindo.Elaborators + -- Elaborate_Library_Graph + -- Elaborate_Units + -- + -- * Invalid invocation graph + -- + -- The invocation graph is invalid when: + -- + -- - An edge lacks an attribute + -- - A vertex lacks an attribute + -- + -- Find the malformed edge or vertex and determine which attribute is + -- missing. Examine the contents of the invocation-related ALI tables + -- available via switch -d_A. If the invocation construct or relation + -- is missing, verify the ALI file. If the ALI lacks all the relevant + -- information, then Sem_Elab most likely failed to discover a valid + -- elaboration path. + -- + -- Units and routines of interest: + -- Bindo.Builders + -- Bindo.Graphs + -- Add_Edge + -- Add_Vertex + -- Build_Invocation_Graph + -- + -- * Invalid library graph + -- + -- The library graph is invalid when: + -- + -- - An edge lacks an attribute + -- - A vertex lacks an attribute + -- + -- Find the malformed edge or vertex and determine which attribute is + -- missing. + -- + -- Units and routines of interest: + -- Bindo.Builders + -- Bindo.Graphs + -- Add_Edge + -- Add_Vertex + -- Build_Library_Graph + -- + -- * Invalid library-graph cycle + -- + -- A library-graph cycle is invalid when: + -- + -- - It lacks enough edges to form a circuit + -- - At least one edge in the circuit is repeated + -- + -- Find the malformed cycle and determine which attribute is missing. + -- + -- Units and routines of interest: + -- Bindo.Graphs + -- Find_Cycles ---------------------------- -- Find_Elaboration_Order -- @@ -281,7 +499,20 @@ package body Bindo is Main_Lib_File : File_Name_Type) is begin - Elaborate_Units (Order, Main_Lib_File); + -- Use the library graph and heuristic-based elaboration order when + -- switch -H (legacy elaboration-order mode enabled). + + if Legacy_Elaboration_Order then + Binde.Find_Elab_Order (Order, Main_Lib_File); + + -- Otherwise use the invocation and library-graph-based elaboration + -- order. + + else + Invocation_And_Library_Graph_Elaborators.Elaborate_Units + (Order => Order, + Main_Lib_File => Main_Lib_File); + end if; end Find_Elaboration_Order; end Bindo; diff --git a/gcc/ada/bindo.ads b/gcc/ada/bindo.ads index 39cf7a4..ae35c95 100644 --- a/gcc/ada/bindo.ads +++ b/gcc/ada/bindo.ads @@ -31,6 +31,32 @@ with Namet; use Namet; package Bindo is + -- The following type represents the various phases of the elaboration + -- order mechanism. + + type Elaboration_Phase is + (Component_Discovery, + Cycle_Diagnostics, + Cycle_Discovery, + Cycle_Validation, + Elaboration_Order_Validation, + Invocation_Graph_Construction, + Invocation_Graph_Validation, + Library_Graph_Augmentation, + Library_Graph_Construction, + Library_Graph_Elaboration, + Library_Graph_Validation, + Unit_Collection, + Unit_Elaboration); + + -- The following type represents the various kinds of precedence between + -- two items. + + type Precedence_Kind is + (Lower_Precedence, + Equal_Precedence, + Higher_Precedence); + procedure Find_Elaboration_Order (Order : out Unit_Id_Table; Main_Lib_File : File_Name_Type); diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index 8c51d11..8331745 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -143,6 +143,11 @@ package body Bindusg is Write_Line (" -h Output this usage (help) information"); + -- Line for -H switch + + Write_Line + (" -H Legacy elaboration order model enabled"); + -- Lines for -I switch Write_Line @@ -173,6 +178,12 @@ package body Bindusg is (" -mnnn Limit number of detected errors/warnings to nnn " & "(1-999999)"); + -- Line for -minimal switch + + Write_Line + (" -minimal Generate binder file suitable for space-constrained " + & "applications"); + -- Line for -M switch Write_Line diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 33fb27e..708bd9e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -435,7 +435,7 @@ package body Checks is -- Fall through for cases where we do set the flag - Set_Do_Overflow_Check (N, True); + Set_Do_Overflow_Check (N); Possible_Local_Raise (N, Standard_Constraint_Error); end Activate_Overflow_Check; @@ -577,8 +577,10 @@ package body Checks is Typ : Entity_Id; Insert_Node : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Param_Ent : Entity_Id := Param_Entity (N); + Loc : constant Source_Ptr := Sloc (N); + + Check_Cond : Node_Id; + Param_Ent : Entity_Id := Param_Entity (N); Param_Level : Node_Id; Type_Level : Node_Id; @@ -617,21 +619,49 @@ package body Checks is Param_Level := New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); - Type_Level := - Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); + -- Use the dynamic accessibility parameter for the function's result + -- when one has been created instead of statically referring to the + -- deepest type level so as to appropriatly handle the rules for + -- RM 3.10.2 (10.1/3). + + if Ekind_In (Scope (Param_Ent), E_Function, + E_Operator, + E_Subprogram_Type) + and then Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) + then + Type_Level := + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); + else + Type_Level := + Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); + end if; -- Raise Program_Error if the accessibility level of the access -- parameter is deeper than the level of the target access type. + Check_Cond := + Make_Op_Gt (Loc, + Left_Opnd => Param_Level, + Right_Opnd => Type_Level); + Insert_Action (Insert_Node, Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Param_Level, - Right_Opnd => Type_Level), - Reason => PE_Accessibility_Check_Failed)); + Condition => Check_Cond, + Reason => PE_Accessibility_Check_Failed)); Analyze_And_Resolve (N); + + -- If constant folding has happened on the condition for the + -- generated error, then warn about it being unconditional. + + if Nkind (Check_Cond) = N_Identifier + and then Entity (Check_Cond) = Standard_True + then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_N ("accessibility check fails<<", N); + Error_Msg_N ("\Program_Error [<<", N); + end if; end if; end Apply_Accessibility_Check; @@ -2707,6 +2737,41 @@ package body Checks is -- Here for normal case of predicate active else + -- If the expression is an IN parameter, the predicate will have + -- been applied at the point of call. An additional check would + -- be redundant, or will lead to out-of-scope references if the + -- call appears within an aspect specification for a precondition. + + -- However, if the reference is within the body of the subprogram + -- that declares the formal, the predicate can safely be applied, + -- which may be necessary for a nested call whose formal has a + -- different predicate. + + if Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_In_Parameter + then + declare + In_Body : Boolean := False; + P : Node_Id := Parent (N); + + begin + while Present (P) loop + if Nkind (P) = N_Subprogram_Body + and then Corresponding_Spec (P) = Scope (Entity (N)) + then + In_Body := True; + exit; + end if; + + P := Parent (P); + end loop; + + if not In_Body then + return; + end if; + end; + end if; + -- If the type has a static predicate and the expression is known -- at compile time, see if the expression satisfies the predicate. @@ -3557,13 +3622,14 @@ package body Checks is -- will not be generated. if GNATprove_Mode - or else not Is_Fixed_Point_Type (Expr_Type) + or else (not Is_Fixed_Point_Type (Expr_Type) + and then not Is_Fixed_Point_Type (Target_Type)) then Apply_Scalar_Range_Check (Expr, Target_Type, Fixed_Int => Conv_OK); else - Set_Do_Range_Check (Expression (N), False); + Set_Do_Range_Check (Expr, False); end if; -- If the target type has predicates, we need to indicate @@ -6775,18 +6841,19 @@ package body Checks is Source_Base_Type : constant Entity_Id := Base_Type (Source_Type); Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); - procedure Convert_And_Check_Range; - -- Convert the conversion operand to the target base type and save in - -- a temporary. Then check the converted value against the range of the - -- target subtype. + procedure Convert_And_Check_Range (Suppress : Check_Id); + -- Convert N to the target base type and save the result in a temporary. + -- The action is analyzed using the default checks as modified by the + -- given Suppress argument. Then check the converted value against the + -- range of the target subtype. ----------------------------- -- Convert_And_Check_Range -- ----------------------------- - procedure Convert_And_Check_Range is - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Conv_Node : Node_Id; + procedure Convert_And_Check_Range (Suppress : Check_Id) is + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Conv_N : Node_Id; begin -- For enumeration types with non-standard representation this is a @@ -6801,36 +6868,26 @@ package body Checks is and then Present (Enum_Pos_To_Rep (Source_Base_Type)) and then Is_Integer_Type (Target_Base_Type) then - Conv_Node := - OK_Convert_To - (Typ => Target_Base_Type, - Expr => Duplicate_Subexpr (N)); - - -- Common case - + Conv_N := OK_Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); else - Conv_Node := - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), - Expression => Duplicate_Subexpr (N)); + Conv_N := Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); end if; - -- We make a temporary to hold the value of the converted value - -- (converted to the base type), and then do the test against this - -- temporary. The conversion itself is replaced by an occurrence of - -- Tnn and followed by the explicit range check. Note that checks - -- are suppressed for this code, since we don't want a recursive - -- range check popping up. + -- We make a temporary to hold the value of the conversion to the + -- target base type, and then do the test against this temporary. + -- N itself is replaced by an occurrence of Tnn and followed by + -- the explicit range check. -- Tnn : constant Target_Base_Type := Target_Base_Type (N); -- [constraint_error when Tnn not in Target_Type] + -- Tnn Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Tnn, Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), Constant_Present => True, - Expression => Conv_Node), + Expression => Conv_N), Make_Raise_Constraint_Error (Loc, Condition => @@ -6838,7 +6895,7 @@ package body Checks is Left_Opnd => New_Occurrence_Of (Tnn, Loc), Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), Reason => Reason)), - Suppress => All_Checks); + Suppress => Suppress); Rewrite (N, New_Occurrence_Of (Tnn, Loc)); @@ -6855,7 +6912,7 @@ package body Checks is -- First special case, if the source type is already within the range -- of the target type, then no check is needed (probably we should have -- stopped Do_Range_Check from being set in the first place, but better - -- late than never in preventing junk code and junk flag settings. + -- late than never in preventing junk code and junk flag settings). if In_Subrange_Of (Source_Type, Target_Type) @@ -6932,7 +6989,8 @@ package body Checks is -- Next test for the case where the target type is within the bounds -- of the base type of the source type, since in this case we can - -- simply convert these bounds to the base type of T to do the test. + -- simply convert the bounds of the target type to this base bype + -- to do the test. -- [constraint_error when N not in -- Source_Base_Type (Target_Type'First) @@ -6981,26 +7039,32 @@ package body Checks is Suppress => All_Checks); -- For conversions involving at least one type that is not discrete, - -- first convert to target type and then generate the range check. - -- This avoids problems with values that are close to a bound of the - -- target type that would fail a range check when done in a larger - -- source type before converting but would pass if converted with + -- first convert to the target base type and then generate the range + -- check. This avoids problems with values that are close to a bound + -- of the target type that would fail a range check when done in a + -- larger source type before converting but pass if converted with -- rounding and then checked (such as in float-to-float conversions). + -- Note that overflow checks are not suppressed for this code because + -- we do not know whether the source type is in range of the target + -- base type (unlike in the next case below). + else - Convert_And_Check_Range; + Convert_And_Check_Range (Suppress => Range_Check); end if; - -- Note that at this stage we now that the Target_Base_Type is not in + -- Note that at this stage we know that the Target_Base_Type is not in -- the range of the Source_Base_Type (since even the Target_Type itself -- is not in this range). It could still be the case that Source_Type is -- in range of the target base type since we have not checked that case. -- If that is the case, we can freely convert the source to the target, - -- and then test the target result against the bounds. + -- and then test the target result against the bounds. Note that checks + -- are suppressed for this code, since we don't want a recursive range + -- check popping up. elsif In_Subrange_Of (Source_Type, Target_Base_Type) then - Convert_And_Check_Range; + Convert_And_Check_Range (Suppress => All_Checks); -- At this stage, we know that we have two scalar types, which are -- directly convertible, and where neither scalar type has a base diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c index dd91a3e..7fca412 100644 --- a/gcc/ada/cio.c +++ b/gcc/ada/cio.c @@ -30,8 +30,7 @@ ****************************************************************************/ #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" +#include "runtime.h" #include <sys/stat.h> #else #include "config.h" diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index fa522ee..565d22e 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -854,7 +854,7 @@ package body Clean is then Project_File_Name := new String' - (Prj (Prj'First + 1 .. Prj'Last)); + (Prj (Prj'First + 1 .. Prj'Last)); else Project_File_Name := new String'(Prj); end if; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index af7c1b9..4610b53 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -25,7 +25,6 @@ with Aspects; use Aspects; with Atree; use Atree; -with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -51,7 +50,6 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with SCIL_LL; use SCIL_LL; with Tbuild; use Tbuild; package body Contracts is @@ -63,11 +61,6 @@ package body Contracts is -- -- Part_Of - procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id); - -- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the - -- contract-only subprogram body of eligible subprograms found in L, adds - -- them to their corresponding list of declarations, and analyzes them. - procedure Expand_Subprogram_Contract (Body_Id : Entity_Id); -- Expand the contracts of a subprogram body and its correspoding spec (if -- any). This routine processes all [refined] pre- and postconditions as @@ -354,10 +347,6 @@ package body Contracts is Decl : Node_Id; begin - if CodePeer_Mode and then Debug_Flag_Dot_KK then - Build_And_Analyze_Contract_Only_Subprograms (L); - end if; - Decl := First (L); while Present (Decl) loop @@ -1305,490 +1294,6 @@ package body Contracts is Restore_SPARK_Mode (Saved_SM, Saved_SMP); end Analyze_Task_Contract; - ------------------------------------------------- - -- Build_And_Analyze_Contract_Only_Subprograms -- - ------------------------------------------------- - - procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id) is - procedure Analyze_Contract_Only_Subprograms; - -- Analyze the contract-only subprograms of L - - procedure Append_Contract_Only_Subprograms (Subp_List : List_Id); - -- Append the contract-only bodies of Subp_List to its declarations list - - function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id; - -- If E is an entity for a non-imported subprogram specification with - -- pre/postconditions and we are compiling with CodePeer mode, then - -- this procedure will create a wrapper to help Gnat2scil process its - -- contracts. Return Empty if the wrapper cannot be built. - - function Build_Contract_Only_Subprograms (L : List_Id) return List_Id; - -- Build the contract-only subprograms of all eligible subprograms found - -- in list L. - - function Has_Private_Declarations (N : Node_Id) return Boolean; - -- Return True for package specs, task definitions, and protected type - -- definitions whose list of private declarations is not empty. - - --------------------------------------- - -- Analyze_Contract_Only_Subprograms -- - --------------------------------------- - - procedure Analyze_Contract_Only_Subprograms is - procedure Analyze_Contract_Only_Bodies; - -- Analyze all the contract-only bodies of L - - ---------------------------------- - -- Analyze_Contract_Only_Bodies -- - ---------------------------------- - - procedure Analyze_Contract_Only_Bodies is - Decl : Node_Id; - - begin - Decl := First (L); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Body - and then Is_Contract_Only_Body - (Defining_Unit_Name (Specification (Decl))) - then - Analyze (Decl); - end if; - - Next (Decl); - end loop; - end Analyze_Contract_Only_Bodies; - - -- Start of processing for Analyze_Contract_Only_Subprograms - - begin - if Ekind (Current_Scope) /= E_Package then - Analyze_Contract_Only_Bodies; - - else - declare - Pkg_Spec : constant Node_Id := - Package_Specification (Current_Scope); - - begin - if not Has_Private_Declarations (Pkg_Spec) then - Analyze_Contract_Only_Bodies; - - -- For packages with private declarations, the contract-only - -- bodies of subprograms defined in the visible part of the - -- package are added to its private declarations (to ensure - -- that they do not cause premature freezing of types and also - -- that they are analyzed with proper visibility). Hence they - -- will be analyzed later. - - elsif Visible_Declarations (Pkg_Spec) = L then - null; - - elsif Private_Declarations (Pkg_Spec) = L then - Analyze_Contract_Only_Bodies; - end if; - end; - end if; - end Analyze_Contract_Only_Subprograms; - - -------------------------------------- - -- Append_Contract_Only_Subprograms -- - -------------------------------------- - - procedure Append_Contract_Only_Subprograms (Subp_List : List_Id) is - begin - if No (Subp_List) then - return; - end if; - - if Ekind (Current_Scope) /= E_Package then - Append_List (Subp_List, To => L); - - else - declare - Pkg_Spec : constant Node_Id := - Package_Specification (Current_Scope); - - begin - if not Has_Private_Declarations (Pkg_Spec) then - Append_List (Subp_List, To => L); - - -- If the package has private declarations then append them to - -- its private declarations; they will be analyzed when the - -- contracts of its private declarations are analyzed. - - else - Append_List - (List => Subp_List, - To => Private_Declarations (Pkg_Spec)); - end if; - end; - end if; - end Append_Contract_Only_Subprograms; - - ------------------------------------ - -- Build_Contract_Only_Subprogram -- - ------------------------------------ - - -- This procedure takes care of building a wrapper to generate better - -- analysis results in the case of a call to a subprogram whose body - -- is unavailable to CodePeer but whose specification includes Pre/Post - -- conditions. The body might be unavailable for any of a number or - -- reasons (it is imported, the .adb file is simply missing, or the - -- subprogram might be subject to an Annotate (CodePeer, Skip_Analysis) - -- pragma). The built subprogram has the following contents: - -- * check preconditions - -- * call the subprogram - -- * check postconditions - - function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (E); - - Missing_Body_Name : constant Name_Id := - New_External_Name (Chars (E), "__missing_body"); - - function Build_Missing_Body_Decls return List_Id; - -- Build the declaration of the missing body subprogram and its - -- corresponding pragma Import. - - function Build_Missing_Body_Subprogram_Call return Node_Id; - -- Build the call to the missing body subprogram - - function Skip_Contract_Only_Subprogram (E : Entity_Id) return Boolean; - -- Return True for cases where the wrapper is not needed or we cannot - -- build it. - - ------------------------------ - -- Build_Missing_Body_Decls -- - ------------------------------ - - function Build_Missing_Body_Decls return List_Id is - Spec : constant Node_Id := Declaration_Node (E); - Decl : Node_Id; - Prag : Node_Id; - - begin - Decl := - Make_Subprogram_Declaration (Loc, Copy_Subprogram_Spec (Spec)); - Set_Chars (Defining_Entity (Decl), Missing_Body_Name); - - Prag := - Make_Pragma (Loc, - Chars => Name_Import, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Ada)), - - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Missing_Body_Name)))); - - return New_List (Decl, Prag); - end Build_Missing_Body_Decls; - - ---------------------------------------- - -- Build_Missing_Body_Subprogram_Call -- - ---------------------------------------- - - function Build_Missing_Body_Subprogram_Call return Node_Id is - Forml : Entity_Id; - Parms : List_Id; - - begin - Parms := New_List; - - -- Build parameter list that we need - - Forml := First_Formal (E); - while Present (Forml) loop - Append_To (Parms, Make_Identifier (Loc, Chars (Forml))); - Next_Formal (Forml); - end loop; - - -- Build the call to the missing body subprogram - - if Ekind_In (E, E_Function, E_Generic_Function) then - return - Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => - Make_Identifier (Loc, Missing_Body_Name), - Parameter_Associations => Parms)); - - else - return - Make_Procedure_Call_Statement (Loc, - Name => - Make_Identifier (Loc, Missing_Body_Name), - Parameter_Associations => Parms); - end if; - end Build_Missing_Body_Subprogram_Call; - - ----------------------------------- - -- Skip_Contract_Only_Subprogram -- - ----------------------------------- - - function Skip_Contract_Only_Subprogram - (E : Entity_Id) return Boolean - is - function Depends_On_Enclosing_Private_Type return Boolean; - -- Return True if some formal of E (or its return type) are - -- private types defined in an enclosing package. - - function Some_Enclosing_Package_Has_Private_Decls return Boolean; - -- Return True if some enclosing package of the current scope has - -- private declarations. - - --------------------------------------- - -- Depends_On_Enclosing_Private_Type -- - --------------------------------------- - - function Depends_On_Enclosing_Private_Type return Boolean is - function Defined_In_Enclosing_Package - (Typ : Entity_Id) return Boolean; - -- Return True if Typ is an entity defined in an enclosing - -- package of the current scope. - - ---------------------------------- - -- Defined_In_Enclosing_Package -- - ---------------------------------- - - function Defined_In_Enclosing_Package - (Typ : Entity_Id) return Boolean - is - Scop : Entity_Id := Scope (Current_Scope); - - begin - while Scop /= Scope (Typ) - and then not Is_Compilation_Unit (Scop) - loop - Scop := Scope (Scop); - end loop; - - return Scop = Scope (Typ); - end Defined_In_Enclosing_Package; - - -- Local variables - - Param_E : Entity_Id; - Typ : Entity_Id; - - -- Start of processing for Depends_On_Enclosing_Private_Type - - begin - Param_E := First_Entity (E); - while Present (Param_E) loop - Typ := Etype (Param_E); - - if Is_Private_Type (Typ) - and then Defined_In_Enclosing_Package (Typ) - then - return True; - end if; - - Next_Entity (Param_E); - end loop; - - return - Ekind (E) = E_Function - and then Is_Private_Type (Etype (E)) - and then Defined_In_Enclosing_Package (Etype (E)); - end Depends_On_Enclosing_Private_Type; - - ---------------------------------------------- - -- Some_Enclosing_Package_Has_Private_Decls -- - ---------------------------------------------- - - function Some_Enclosing_Package_Has_Private_Decls return Boolean is - Scop : Entity_Id := Current_Scope; - Pkg_Spec : Node_Id := Package_Specification (Scop); - - begin - loop - if Ekind (Scop) = E_Package - and then Has_Private_Declarations - (Package_Specification (Scop)) - then - Pkg_Spec := Package_Specification (Scop); - end if; - - exit when Is_Compilation_Unit (Scop); - Scop := Scope (Scop); - end loop; - - return Pkg_Spec /= Package_Specification (Current_Scope); - end Some_Enclosing_Package_Has_Private_Decls; - - -- Start of processing for Skip_Contract_Only_Subprogram - - begin - if not CodePeer_Mode - or else Inside_A_Generic - or else not Is_Subprogram (E) - or else Is_Abstract_Subprogram (E) - or else Is_Imported (E) - or else No (Contract (E)) - or else No (Pre_Post_Conditions (Contract (E))) - or else Is_Contract_Only_Body (E) - or else Convention (E) = Convention_Protected - then - return True; - - -- We do not support building the contract-only subprogram if E - -- is a subprogram declared in a nested package that has some - -- formal or return type depending on a private type defined in - -- an enclosing package. - - elsif Ekind (Current_Scope) = E_Package - and then Some_Enclosing_Package_Has_Private_Decls - and then Depends_On_Enclosing_Private_Type - then - if Debug_Flag_Dot_KK then - declare - Saved_Mode : constant Warning_Mode_Type := Warning_Mode; - - begin - -- Warnings are disabled by default under CodePeer_Mode - -- (see switch-c). Enable them temporarily. - - Warning_Mode := Normal; - Error_Msg_N - ("cannot generate contract-only subprogram?", E); - Warning_Mode := Saved_Mode; - end; - end if; - - return True; - end if; - - return False; - end Skip_Contract_Only_Subprogram; - - -- Start of processing for Build_Contract_Only_Subprogram - - begin - -- Test cases where the wrapper is not needed and cases where we - -- cannot build it. - - if Skip_Contract_Only_Subprogram (E) then - return Empty; - end if; - - -- Note on calls to Copy_Separate_Tree. The trees we are copying - -- here are fully analyzed, but we definitely want fully syntactic - -- unanalyzed trees in the body we construct, so that the analysis - -- generates the right visibility, and that is exactly what the - -- calls to Copy_Separate_Tree give us. - - declare - Name : constant Name_Id := - New_External_Name (Chars (E), "__contract_only"); - Id : Entity_Id; - Bod : Node_Id; - - begin - Bod := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Declaration_Node (E)), - Declarations => - Build_Missing_Body_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Build_Missing_Body_Subprogram_Call), - End_Label => Make_Identifier (Loc, Name))); - - Id := Defining_Unit_Name (Specification (Bod)); - - -- Copy only the pre/postconditions of the original contract - -- since it is what we need, but also because pragmas stored in - -- the other fields have N_Pragmas with N_Aspect_Specifications - -- that reference their associated pragma (thus causing an endless - -- loop when trying to copy the subtree). - - declare - New_Contract : constant Node_Id := Make_Contract (Sloc (E)); - - begin - Set_Pre_Post_Conditions (New_Contract, - Copy_Separate_Tree (Pre_Post_Conditions (Contract (E)))); - Set_Contract (Id, New_Contract); - end; - - -- Fix the name of this new subprogram and link the original - -- subprogram with its Contract_Only_Body subprogram. - - Set_Chars (Id, Name); - Set_Is_Contract_Only_Body (Id); - Set_Contract_Only_Body (E, Id); - - return Bod; - end; - end Build_Contract_Only_Subprogram; - - ------------------------------------- - -- Build_Contract_Only_Subprograms -- - ------------------------------------- - - function Build_Contract_Only_Subprograms (L : List_Id) return List_Id is - Decl : Node_Id; - New_Subp : Node_Id; - Result : List_Id := No_List; - Subp_Id : Entity_Id; - - begin - Decl := First (L); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Declaration then - Subp_Id := Defining_Unit_Name (Specification (Decl)); - New_Subp := Build_Contract_Only_Subprogram (Subp_Id); - - if Present (New_Subp) then - if No (Result) then - Result := New_List; - end if; - - Append_To (Result, New_Subp); - end if; - end if; - - Next (Decl); - end loop; - - return Result; - end Build_Contract_Only_Subprograms; - - ------------------------------ - -- Has_Private_Declarations -- - ------------------------------ - - function Has_Private_Declarations (N : Node_Id) return Boolean is - begin - if not Nkind_In (N, N_Package_Specification, - N_Protected_Definition, - N_Task_Definition) - then - return False; - else - return - Present (Private_Declarations (N)) - and then Is_Non_Empty_List (Private_Declarations (N)); - end if; - end Has_Private_Declarations; - - -- Local variables - - Subp_List : List_Id; - - -- Start of processing for Build_And_Analyze_Contract_Only_Subprograms - - begin - Subp_List := Build_Contract_Only_Subprograms (L); - Append_Contract_Only_Subprograms (Subp_List); - Analyze_Contract_Only_Subprograms; - end Build_And_Analyze_Contract_Only_Subprograms; - ----------------------------- -- Create_Generic_Contract -- ----------------------------- diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index e37070d..92392fc 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -53,9 +53,7 @@ #endif #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" -#include <sys/stat.h> +#include <string.h> #else #include "config.h" #include "system.h" diff --git a/gcc/ada/ctrl_c.c b/gcc/ada/ctrl_c.c index 546faa7..0e427ea 100644 --- a/gcc/ada/ctrl_c.c +++ b/gcc/ada/ctrl_c.c @@ -29,11 +29,7 @@ * * ****************************************************************************/ -#ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" -#include <sys/stat.h> -#else +#ifndef IN_RTS #include "config.h" #include "system.h" #endif diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d76d93d..6a5d0ea 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -128,7 +128,7 @@ package body Debug is -- d.H GNSA mode for ASIS -- d.I Do not ignore enum representation clauses in CodePeer mode -- d.J Relaxed rules for pragma No_Return - -- d.K Enable generation of contract-only procedures in CodePeer mode + -- d.K -- d.L Depend on back end for limited types in if and case expressions -- d.M Relaxed RM semantics -- d.N Add node to all entities @@ -154,7 +154,7 @@ package body Debug is -- d_g -- d_h -- d_i Ignore activations and calls to instances for elaboration - -- d_j + -- d_j Read JSON files and populate Repinfo tables (opposite of -gnatRjs) -- d_k -- d_l -- d_m @@ -178,7 +178,7 @@ package body Debug is -- d_D -- d_E -- d_F Encode full invocation paths in ALI files - -- d_G Encode invocation graph in ALI files + -- d_G -- d_H -- d_I -- d_J @@ -349,11 +349,11 @@ package body Debug is -- d.8 -- d.9 - -- d_a - -- d_b + -- d_a Ignore the effects of pragma Elaborate_All + -- d_b Ignore the effects of pragma Elaborate_Body -- d_c -- d_d - -- d_e + -- d_e Ignore the effects of pragma Elaborate -- d_f -- d_g -- d_h @@ -368,7 +368,7 @@ package body Debug is -- d_q -- d_r -- d_s - -- d_t + -- d_t Output cycle-detection trace information -- d_u -- d_v -- d_w @@ -378,8 +378,9 @@ package body Debug is -- d_A Output ALI invocation tables -- d_B - -- d_C + -- d_C Diagnose all cycles -- d_D + -- d_E -- d_F -- d_G -- d_H @@ -388,15 +389,15 @@ package body Debug is -- d_K -- d_L Output library graph -- d_M - -- d_N New bindo order - -- d_O Output elaboration order - -- d_P + -- d_N + -- d_O + -- d_P Output cycle paths -- d_Q -- d_R - -- d_S - -- d_T Output elaboration order trace information + -- d_S Output elaboration-order status + -- d_T Output elaboration-order trace information -- d_U - -- d_V Validate bindo graphs and order + -- d_V Validate bindo cycles, graphs, and order -- d_W -- d_X -- d_Y @@ -601,10 +602,11 @@ package body Debug is -- dE Apply compile time elaboration checking for with relations between -- predefined units. Normally no checks are made. - -- dF Perform the new SPARK checking rules for pointer aliasing. This is - -- only activated in GNATprove mode and on SPARK code. These rules are - -- not yet part of the official SPARK language, but are expected to be - -- included in a future version of SPARK. + -- dF Disable the new SPARK checking rules for pointer aliasing. This is + -- only activated as part of GNATprove mode and on SPARK code. Now + -- that pointer support is part of the official SPARK language, this + -- switch allows reverting to the previous version of GNATprove + -- rejecting pointers. -- dG Generate all warnings. Normally Errout suppresses warnings on -- units that are not part of the main extended source, and also @@ -904,13 +906,6 @@ package body Debug is -- for that. If the procedure does in fact return normally, execution -- is erroneous, and therefore unpredictable. - -- d.K Enable generation of contract-only procedures in CodePeer mode and - -- report a warning on subprograms for which the contract-only body - -- cannot be built. Currently reported on subprograms defined in - -- nested package specs that have some formal (or return type) whose - -- type is a private type defined in some enclosing package and that - -- have pre/postconditions. - -- d.L Normally the front end generates special expansion for conditional -- expressions of a limited type. This debug flag removes this special -- case expansion, leaving it up to the back end to handle conditional @@ -994,6 +989,10 @@ package body Debug is -- subprogram or task type defined in an external instance for both -- the static and dynamic elaboration models. + -- d_j The compiler reads JSON files that would be generated by the same + -- compilation session if -gnatRjs was passed, in order to populate + -- the internal tables of the Repinfo unit from them. + -- d_p The compiler ignores calls to subprograms which verify the run-time -- semantics of invariants and postconditions in both the static and -- dynamic elaboration models. @@ -1008,9 +1007,6 @@ package body Debug is -- an external target, offering additional information to GNATBIND for -- purposes of error diagnostics. - -- d_G The compiler encodes the invocation graph of a unit in its ALI - -- file. - -- d_L Output trace information on elaboration checking. This debug switch -- causes output to be generated showing each call or instantiation as -- it is checked, and the progress of the recursive trace through @@ -1148,24 +1144,42 @@ package body Debug is -- dx Force the binder to read (and then ignore) the xref information -- in ali files (used to check that read circuit is working OK). + -- d_a GNATBIND ignores the effects of pragma Elaborate_All in the case of + -- elaboration order and treats the associated dependency as a regular + -- with edge. + + -- d_b GNATBIND ignores the effects of pragma Elaborate_Body in the case + -- of elaboration order and treats the spec and body as decoupled. + + -- d_e GNATBIND ignores the effects of pragma Elaborate in the case of + -- elaboration order and no longer creates an implicit dependency on + -- the body of the argument. + + -- d_t GNATBIND output trace information of cycle-detection activities to + -- standard output. + -- d_A GNATBIND output the contents of all ALI invocation-related tables -- in textual format to standard output. - -- + + -- d_C GNATBIND diagnoses all unique cycles within the bind, rather than + -- just the most important one. + -- d_I GNATBIND outputs the contents of the invocation graph in textual -- format to standard output. - -- + -- d_L GNATBIND outputs the contents of the library graph in textual -- format to standard output. - -- - -- d_N GNATBIND utilizes the elaboration order provided by bindo - -- - -- d_O GNATBIND outputs the elaboration order of units to standard output - -- - -- d_T GNATBIND outputs trace information of elaboration order activities - -- to standard output. - -- - -- d_V GNATBIND validates the invocation graph, library graph, SCC graph - -- and elaboration order. + + -- d_P GNATBIND outputs the cycle paths to standard output + + -- d_S GNATBIND outputs trace information concerning the status of its + -- various phases to standard output. + + -- d_T GNATBIND outputs trace information of elaboration order detection + -- activities to standard output. + + -- d_V GNATBIND validates the invocation graph, library graph along with + -- its cycles, and the elaboration order. -------------------------------------------- -- Documentation for gnatmake Debug Flags -- diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index 0b4f780..db75ea7 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -479,17 +479,17 @@ Attribute Img ============= .. index:: Img -The ``Img`` attribute differs from ``Image`` in that it is applied -directly to an object, and yields the same result as -``Image`` for the subtype of the object. This is convenient for -debugging: +The ``Img`` attribute differs from ``Image`` in that, while both can be +applied directly to an object, ``Img`` cannot be applied to types. + +Example usage of the attribute: .. code-block:: ada Put_Line ("X = " & X'Img); -has the same meaning as the more verbose: +which has the same meaning as the more verbose: .. code-block:: ada @@ -967,8 +967,8 @@ of the use of this feature: -- the former is used. -Other properties are as for standard representation attribute ``Bit_Order``, -as defined by Ada RM 13.5.3(4). The default is ``System.Default_Bit_Order``. +Other properties are as for the standard representation attribute ``Bit_Order`` +defined by Ada RM 13.5.3(4). The default is ``System.Default_Bit_Order``. For a record type ``T``, if ``T'Scalar_Storage_Order`` is specified explicitly, it shall be equal to ``T'Bit_Order``. Note: @@ -978,8 +978,8 @@ specified explicitly and set to the same value. Derived types inherit an explicitly set scalar storage order from their parent types. This may be overridden for the derived type by giving an explicit scalar -storage order for the derived type. For a record extension, the derived type -must have the same scalar storage order as the parent type. +storage order for it. However, for a record extension, the derived type must +have the same scalar storage order as the parent type. A component of a record type that is itself a record or an array and that does not start and end on a byte boundary must have have the same scalar storage @@ -1018,15 +1018,18 @@ inheritance in the case of a derived type), then the default is normally the native ordering of the target, but this default can be overridden using pragma ``Default_Scalar_Storage_Order``. -Note that if a component of ``T`` is itself of a record or array type, -the specfied ``Scalar_Storage_Order`` does *not* apply to that nested type: -an explicit attribute definition clause must be provided for the component -type as well if desired. +If a component of ``T`` is itself of a record or array type, the specfied +``Scalar_Storage_Order`` does *not* apply to that nested type: an explicit +attribute definition clause must be provided for the component type as well +if desired. Note that the scalar storage order only affects the in-memory data representation. It has no effect on the representation used by stream attributes. +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. + .. _Attribute_Simple_Storage_Pool: Attribute Simple_Storage_Pool diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 955a137..04b0def 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -719,7 +719,7 @@ Syntax: .. code-block:: ada - pragma Asynch_Readers [ (boolean_EXPRESSION) ]; + pragma Async_Readers [ (boolean_EXPRESSION) ]; For the semantics of this pragma, see the entry for aspect ``Async_Readers`` in the SPARK 2014 Reference Manual, section 7.1.2. @@ -733,7 +733,7 @@ Syntax: .. code-block:: ada - pragma Asynch_Writers [ (boolean_EXPRESSION) ]; + pragma Async_Writers [ (boolean_EXPRESSION) ]; For the semantics of this pragma, see the entry for aspect ``Async_Writers`` in the SPARK 2014 Reference Manual, section 7.1.2. @@ -2432,7 +2432,7 @@ with Import and Export pragmas. There are two cases to consider: ``As_Is`` provides the normal default behavior in which the casing is taken from the string provided. -This pragma may appear anywhere that a pragma is valid. In particular, it +This pragma may appear anywhere that a pragma is valid. In particular, it can be used as a configuration pragma in the :file:`gnat.adc` file, in which case it applies to all subsequent compilations, or it can be used as a program unit pragma, in which case it only applies to the current unit, or it can @@ -2999,58 +2999,87 @@ Syntax: .. code-block:: ada - pragma Initialize_Scalars; + pragma Initialize_Scalars + [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ]; + TYPE_VALUE_PAIR ::= + SCALAR_TYPE => static_EXPRESSION -This pragma is similar to ``Normalize_Scalars`` conceptually but has -two important differences. First, there is no requirement for the pragma -to be used uniformly in all units of a partition, in particular, it is fine -to use this just for some or all of the application units of a partition, -without needing to recompile the run-time library. + SCALAR_TYPE := + Short_Float + | Float + | Long_Float + | Long_Long_Flat + | Signed_8 + | Signed_16 + | Signed_32 + | Signed_64 + | Unsigned_8 + | Unsigned_16 + | Unsigned_32 + | Unsigned_64 -In the case where some units are compiled with the pragma, and some without, -then a declaration of a variable where the type is defined in package -Standard or is locally declared will always be subject to initialization, -as will any declaration of a scalar variable. For composite variables, -whether the variable is initialized may also depend on whether the package -in which the type of the variable is declared is compiled with the pragma. -The other important difference is that you can control the value used -for initializing scalar objects. At bind time, you can select several -options for initialization. You can -initialize with invalid values (similar to Normalize_Scalars, though for -Initialize_Scalars it is not always possible to determine the invalid -values in complex cases like signed component fields with non-standard -sizes). You can also initialize with high or -low values, or with a specified bit pattern. See the GNAT -User's Guide for binder options for specifying these cases. +This pragma is similar to ``Normalize_Scalars`` conceptually but has two +important differences. -This means that you can compile a program, and then without having to -recompile the program, you can run it with different values being used -for initializing otherwise uninitialized values, to test if your program -behavior depends on the choice. Of course the behavior should not change, -and if it does, then most likely you have an incorrect reference to an -uninitialized value. +First, there is no requirement for the pragma to be used uniformly in all units +of a partition. In particular, it is fine to use this just for some or all of +the application units of a partition, without needing to recompile the run-time +library. In the case where some units are compiled with the pragma, and some +without, then a declaration of a variable where the type is defined in package +Standard or is locally declared will always be subject to initialization, as +will any declaration of a scalar variable. For composite variables, whether the +variable is initialized may also depend on whether the package in which the +type of the variable is declared is compiled with the pragma. -It is even possible to change the value at execution time eliminating even -the need to rebind with a different switch using an environment variable. -See the GNAT User's Guide for details. +The other important difference is that the programmer can control the value +used for initializing scalar objects. This effect can be achieved in several +different ways: + +* At compile time, the programmer can specify the invalid value for a + particular family of scalar types using the optional arguments of the pragma. + + The compile-time approach is intended to optimize the generated code for the + pragma, by possibly using fast operations such as ``memset``. + +* At bind time, the programmer has several options: + + * Initialization with invalid values (similar to Normalize_Scalars, though + for Initialize_Scalars it is not always possible to determine the invalid + values in complex cases like signed component fields with nonstandard + sizes). + + * Initialization with high values. + + * Initialization with low values. + + * Initialization with a specific bit pattern. -Note that pragma ``Initialize_Scalars`` is particularly useful in -conjunction with the enhanced validity checking that is now provided -in GNAT, which checks for invalid values under more conditions. -Using this feature (see description of the *-gnatV* flag in the -GNAT User's Guide) in conjunction with -pragma ``Initialize_Scalars`` -provides a powerful new tool to assist in the detection of problems -caused by uninitialized variables. - -Note: the use of ``Initialize_Scalars`` has a fairly extensive -effect on the generated code. This may cause your code to be -substantially larger. It may also cause an increase in the amount -of stack required, so it is probably a good idea to turn on stack -checking (see description of stack checking in the GNAT -User's Guide) when using this pragma. + See the GNAT User's Guide for binder options for specifying these cases. + + The bind-time approach is intended to provide fast turnaround for testing + with different values, without having to recompile the program. + +* At execution time, the programmer can speify the invalid values using an + environment variable. See the GNAT User's Guide for details. + + The execution-time approach is intended to provide fast turnaround for + testing with different values, without having to recompile and rebind the + program. + +Note that pragma ``Initialize_Scalars`` is particularly useful in conjunction +with the enhanced validity checking that is now provided in GNAT, which checks +for invalid values under more conditions. Using this feature (see description +of the *-gnatV* flag in the GNAT User's Guide) in conjunction with pragma +``Initialize_Scalars`` provides a powerful new tool to assist in the detection +of problems caused by uninitialized variables. + +Note: the use of ``Initialize_Scalars`` has a fairly extensive effect on the +generated code. This may cause your code to be substantially larger. It may +also cause an increase in the amount of stack required, so it is probably a +good idea to turn on stack checking (see description of stack checking in the +GNAT User's Guide) when using this pragma. .. _Pragma-Initializes: @@ -7312,11 +7341,10 @@ methods can be used to enable validity checking for mode ``in`` and The form ALL_CHECKS activates all standard checks (its use is equivalent -to the use of the :switch:`gnatva` switch. +to the use of the :switch:`gnatVa` switch). -The forms with ``Off`` and ``On`` -can be used to temporarily disable validity checks -as shown in the following example: +The forms with ``Off`` and ``On`` can be used to temporarily disable +validity checks as shown in the following example: .. code-block:: ada 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 7b599be..56dd6a7 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 @@ -356,7 +356,9 @@ No_Exceptions .. index:: No_Exceptions [RM H.4] This restriction ensures at compile time that there are no -raise statements and no exception handlers. +raise statements and no exception handlers and also suppresses the +generation of language-defined run-time checks. + No_Finalization --------------- @@ -633,7 +635,7 @@ No_Stream_Optimizations [GNAT] This restriction affects the performance of stream operations on types ``String``, ``Wide_String`` and ``Wide_Wide_String``. By default, the compiler uses block reads and writes when manipulating ``String`` objects -due to their supperior performance. When this restriction is in effect, the +due to their superior performance. When this restriction is in effect, the compiler performs all IO operations on a per-character basis. No_Streams diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst index e15e239..6b9a410 100644 --- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst +++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst @@ -722,6 +722,17 @@ Provides access to key=value associations captured at bind time. These associations can be specified using the :switch:`-V` binder command line switch. +.. _`GNAT.Branch_Prediction_(g-brapre.ads)`: + +``GNAT.Branch_Prediction`` (:file:`g-brapre.ads`) +================================================= + +.. index:: GNAT.Branch_Prediction (g-brapre.ads) + +.. index:: Branch Prediction + +Provides routines giving hints to the branch predictor of the code generator. + .. _`GNAT.Bounded_Buffers_(g-boubuf.ads)`: ``GNAT.Bounded_Buffers`` (:file:`g-boubuf.ads`) @@ -937,7 +948,7 @@ programs written in Ada. Provides a high level interface to ``Ada.Command_Line`` facilities, including the ability to scan for named switches with optional parameters -and expand file names using wild card notations. +and expand file names using wildcard notations. .. _`GNAT.Compiler_Version_(g-comver.ads)`: diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 57c3fe1..2e867e2 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 @@ -1836,7 +1836,8 @@ Alphabetical List of All Switches .. index:: -gnatE (gcc) :switch:`-gnatE` - Full dynamic elaboration checks. + Dynamic elaboration checking mode enabled. For further details see + :ref:`Elaboration_Order_Handling_in_GNAT`. .. index:: -gnatf (gcc) @@ -1878,8 +1879,9 @@ Alphabetical List of All Switches .. index:: -gnatH (gcc) :switch:`-gnatH` - Legacy elaboration-checking mode enabled. When this switch is in effect, the - pre-18.x access-before-elaboration model becomes the de facto model. + Legacy elaboration-checking mode enabled. When this switch is in effect, + the pre-18.x access-before-elaboration model becomes the de facto model. + For further details see :ref:`Elaboration_Order_Handling_in_GNAT`. .. index:: -gnati (gcc) @@ -1935,7 +1937,8 @@ Alphabetical List of All Switches - Select statements - Synchronous task suspension - and does not emit compile-time diagnostics or run-time checks. + and does not emit compile-time diagnostics or run-time checks. For further + details see :ref:`Elaboration_Order_Handling_in_GNAT`. .. index:: -gnatk (gcc) @@ -2839,6 +2842,29 @@ of the pragma in the :title:`GNAT_Reference_manual`). compile time that the assertion will fail. +.. index:: -gnatw_a + +:switch:`-gnatw_a` + *Activate warnings on anonymous allocators.* + + .. index:: Anonymous allocators + + This switch activates warnings for allocators of anonymous access types, + which can involve run-time accessibility checks and lead to unexpected + accessibility violations. For more details on the rules involved, see + RM 3.10.2 (14). + + +.. index:: -gnatw_A + +:switch:`-gnatw_A` + *Supress warnings on anonymous allocators.* + + .. index:: Anonymous allocators + + This switch suppresses warnings for anonymous access type allocators. + + .. index:: -gnatwb (gcc) :switch:`-gnatwb` @@ -5290,7 +5316,7 @@ Using ``gcc`` for Syntax Checking compiles file :file:`x.adb` in syntax-check-only mode. You can check a series of files in a single command - , and can use wild cards to specify such a group of files. + , and can use wildcards to specify such a group of files. Note that you must specify the :switch:`-c` (compile only) flag in addition to the :switch:`-gnats` flag. @@ -6368,7 +6394,9 @@ be presented in subsequent sections. .. index:: -f (gnatbind) :switch:`-f{elab-order}` - Force elaboration order. + Force elaboration order. For further details see :ref:`Elaboration_Control` + and :ref:`Elaboration_Order_Handling_in_GNAT`. + .. index:: -F (gnatbind) @@ -6388,15 +6416,22 @@ be presented in subsequent sections. Output usage (help) information. - .. index:: -H32 (gnatbind) +.. index:: -H (gnatbind) + +:switch:`-H` + Legacy elaboration order model enabled. For further details see + :ref:`Elaboration_Order_Handling_in_GNAT`. + + +.. index:: -H32 (gnatbind) :switch:`-H32` Use 32-bit allocations for ``__gnat_malloc`` (and thus for access types). For further details see :ref:`Dynamic_Allocation_Control`. - .. index:: -H64 (gnatbind) - .. index:: __gnat_malloc +.. index:: -H64 (gnatbind) +.. index:: __gnat_malloc :switch:`-H64` Use 64-bit allocations for ``__gnat_malloc`` (and thus for access types). @@ -6440,7 +6475,6 @@ be presented in subsequent sections. Rename generated main program from main to xyz. This option is supported on cross environments only. - .. index:: -m (gnatbind) :switch:`-m{n}` @@ -6453,6 +6487,16 @@ be presented in subsequent sections. A value of zero means that no limit is enforced. The equal sign is optional. + .. index:: -minimal (gnatbind) + +:switch:`-minimal` + Generate a binder file suitable for space-constrained applications. When + active, binder-generated objects not required for program operation are no + longer generated. **Warning:** this option comes with the following + limitations: + + * Debugging will not work; + * Programs using GNAT.Compiler_Version will not link. .. index:: -n (gnatbind) @@ -6816,7 +6860,7 @@ Elaboration Control ^^^^^^^^^^^^^^^^^^^ The following switches provide additional control over the elaboration -order. For full details see :ref:`Elaboration_Order_Handling_in_GNAT`. +order. For further details see :ref:`Elaboration_Order_Handling_in_GNAT`. .. index:: -f (gnatbind) @@ -6860,28 +6904,32 @@ order. For full details see :ref:`Elaboration_Order_Handling_in_GNAT`. ignored. - .. index:: -p (gnatbind) +.. index:: -p (gnatbind) :switch:`-p` - Normally the binder attempts to choose an elaboration order that is - likely to minimize the likelihood of an elaboration order error resulting - in raising a ``Program_Error`` exception. This switch reverses the - action of the binder, and requests that it deliberately choose an order - that is likely to maximize the likelihood of an elaboration error. - This is useful in ensuring portability and avoiding dependence on - accidental fortuitous elaboration ordering. - - Normally it only makes sense to use the :switch:`-p` - switch if dynamic + Pessimistic elaboration order + + This switch is only applicable to the pre-20.x legacy elaboration models. + The post-20.x elaboration model uses a more informed approach of ordering + the units. + + Normally the binder attempts to choose an elaboration order that is likely to + minimize the likelihood of an elaboration order error resulting in raising a + ``Program_Error`` exception. This switch reverses the action of the binder, + and requests that it deliberately choose an order that is likely to maximize + the likelihood of an elaboration error. This is useful in ensuring + portability and avoiding dependence on accidental fortuitous elaboration + ordering. + + Normally it only makes sense to use the :switch:`-p` switch if dynamic elaboration checking is used (:switch:`-gnatE` switch used for compilation). This is because in the default static elaboration mode, all necessary ``Elaborate`` and ``Elaborate_All`` pragmas are implicitly inserted. - These implicit pragmas are still respected by the binder in - :switch:`-p` mode, so a - safe elaboration order is assured. + These implicit pragmas are still respected by the binder in :switch:`-p` + mode, so a safe elaboration order is assured. - Note that :switch:`-p` is not intended for - production use; it is more for debugging/experimental use. + Note that :switch:`-p` is not intended for production use; it is more for + debugging/experimental use. .. _Output_Control: diff --git a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst index 336555c..eb0f905 100644 --- a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst @@ -50,9 +50,14 @@ Elaboration code is executed as follows: In addition to the Ada terminology, this appendix defines the following terms: +* *Invocation* + + The act of calling a subprogram, instantiating a generic, or activating a + task. + * *Scenario* - A construct that is elaborated or executed by elaboration code is referred to + A construct that is elaborated or invoked by elaboration code is referred to as an *elaboration scenario* or simply a **scenario**. GNAT recognizes the following scenarios: @@ -102,7 +107,7 @@ Elaboration code may appear in two distinct contexts: In the example above, the call to ``Server.Func`` is an elaboration scenario because it appears at the library level of package ``Client``. Note that the declaration of package ``Nested`` is ignored according to the definition - given above. As a result, the call to ``Server.Func`` will be executed when + given above. As a result, the call to ``Server.Func`` will be invoked when the spec of unit ``Client`` is elaborated. * *Package body statements* @@ -124,7 +129,7 @@ Elaboration code may appear in two distinct contexts: In the example above, the call to ``Proc`` is an elaboration scenario because it appears within the statement sequence of package body ``Client``. As a - result, the call to ``Proc`` will be executed when the body of ``Client`` is + result, the call to ``Proc`` will be invoked when the body of ``Client`` is elaborated. .. _Elaboration_Order: @@ -137,19 +142,19 @@ executed is referred to as **elaboration order**. Within a single unit, elaboration code is executed in sequential order. -:: + :: - package body Client is - Result : ... := Server.Func; + package body Client is + Result : ... := Server.Func; - procedure Proc is - package Inst is new Server.Gen; - begin - Inst.Eval (Result); - end Proc; - begin - Proc; - end Client; + procedure Proc is + package Inst is new Server.Gen; + begin + Inst.Eval (Result); + end Proc; + begin + Proc; + end Client; In the example above, the elaboration order within package body ``Client`` is as follows: @@ -173,52 +178,56 @@ factors: * |withed| units +* parent units + * purity of units * preelaborability of units -* presence of elaboration control pragmas +* presence of elaboration-control pragmas + +* invocations performed in elaboration code A program may have several elaboration orders depending on its structure. -:: + :: - package Server is - function Func (Index : Integer) return Integer; - end Server; + package Server is + function Func (Index : Integer) return Integer; + end Server; -:: + :: - package body Server is - Results : array (1 .. 5) of Integer := (1, 2, 3, 4, 5); + package body Server is + Results : array (1 .. 5) of Integer := (1, 2, 3, 4, 5); - function Func (Index : Integer) return Integer is - begin - return Results (Index); - end Func; - end Server; + function Func (Index : Integer) return Integer is + begin + return Results (Index); + end Func; + end Server; -:: + :: - with Server; - package Client is - Val : constant Integer := Server.Func (3); - end Client; + with Server; + package Client is + Val : constant Integer := Server.Func (3); + end Client; -:: + :: - with Client; - procedure Main is begin null; end Main; + with Client; + procedure Main is begin null; end Main; The following elaboration order exhibits a fundamental problem referred to as *access-before-elaboration* or simply **ABE**. -:: + :: - spec of Server - spec of Client - body of Server - body of Main + spec of Server + spec of Client + body of Server + body of Main The elaboration of ``Server``'s spec materializes function ``Func``, making it callable. The elaboration of ``Client``'s spec elaborates the declaration of @@ -236,26 +245,27 @@ vein as index or null exclusion checks. A failed ABE check raises exception The following elaboration order avoids the ABE problem and the program can be successfully elaborated. -:: + :: - spec of Server - body of Server - spec of Client - body of Main + spec of Server + body of Server + spec of Client + body of Main Ada states that a total elaboration order must exist, but it does not define what this order is. A compiler is thus tasked with choosing a suitable elaboration order which satisfies the dependencies imposed by |with| clauses, -unit categorization, and elaboration control pragmas. Ideally an order which -avoids ABE problems should be chosen, however a compiler may not always find -such an order due to complications with respect to control and data flow. +unit categorization, elaboration-control pragmas, and invocations performed in +elaboration code. Ideally an order that avoids ABE problems should be chosen, +however a compiler may not always find such an order due to complications with +respect to control and data flow. .. _Checking_the_Elaboration_Order: Checking the Elaboration Order ============================== -To avoid placing the entire elaboration order burden on the programmer, Ada +To avoid placing the entire elaboration-order burden on the programmer, Ada provides three lines of defense: * *Static semantics* @@ -268,7 +278,7 @@ provides three lines of defense: * *Dynamic semantics* Dynamic checks are performed at run time, to ensure that a target is - elaborated prior to a scenario that executes it, thus avoiding ABE problems. + elaborated prior to a scenario that invokes it, thus avoiding ABE problems. A failed run-time check raises exception ``Program_Error``. The following restrictions apply: @@ -290,8 +300,7 @@ provides three lines of defense: The restrictions above can be summarized by the following rule: *If a target has a body, then this body must be elaborated prior to the - execution of the scenario that invokes, instantiates, or activates the - target.* + scenario that invokes the target.* * *Elaboration control* @@ -346,7 +355,7 @@ the desired elaboration order and avoiding ABE problems altogether. Pragma ``Elaborate_Body`` requires that the body of a unit is elaborated immediately after its spec. This restriction guarantees that no client - scenario can execute a server target before the target body has been + scenario can invoke a server target before the target body has been elaborated because the spec and body are effectively "glued" together. :: @@ -536,7 +545,7 @@ depend on. be elaborated prior to ``Client``. Removing pragma ``Elaborate_All`` could result in the following incorrect - elaboration order + elaboration order: :: @@ -601,24 +610,53 @@ elaboration order and to diagnose elaboration problems. * *Dynamic elaboration model* - This is the most permissive of the three elaboration models. When the - dynamic model is in effect, GNAT assumes that all code within all units in - a partition is elaboration code. GNAT performs very few diagnostics and - generates run-time checks to verify the elaboration order of a program. This - behavior is identical to that specified by the Ada Reference Manual. The - dynamic model is enabled with compiler switch :switch:`-gnatE`. + This is the most permissive of the three elaboration models and emulates the + behavior specified by the Ada Reference Manual. When the dynamic model is in + effect, GNAT makes the following assumptions: + + - All code within all units in a partition is considered to be elaboration + code. + + - Some of the invocations in elaboration code may not take place at run time + due to conditional execution. + + GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios + that invoke internal targets. In addition, GNAT generates run-time checks for + all external targets and for all scenarios that may exhibit ABE problems. + + The elaboration order is obtained by honoring all |with| clauses, purity and + preelaborability of units, and elaboration-control pragmas. The dynamic model + attempts to take all invocations in elaboration code into account. If an + invocation leads to a circularity, GNAT ignores the invocation based on the + assumptions stated above. An order obtained using the dynamic model may fail + an ABE check at run time when GNAT ignored an invocation. + + The dynamic model is enabled with compiler switch :switch:`-gnatE`. .. index:: Static elaboration model * *Static elaboration model* This is the middle ground of the three models. When the static model is in - effect, GNAT performs extensive diagnostics on a unit-by-unit basis for all - scenarios that elaborate or execute internal targets. GNAT also generates - run-time checks for all external targets and for all scenarios that may - exhibit ABE problems. Finally, GNAT installs implicit ``Elaborate`` and - ``Elaborate_All`` pragmas for server units based on the dependencies of - client units. The static model is the default model in GNAT. + effect, GNAT makes the following assumptions: + + - Only code at the library level and in package body statements within all + units in a partition is considered to be elaboration code. + + - All invocations in elaboration will take place at run time, regardless of + conditional execution. + + GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios + that invoke internal targets. In addition, GNAT generates run-time checks for + all external targets and for all scenarios that may exhibit ABE problems. + + The elaboration order is obtained by honoring all |with| clauses, purity and + preelaborability of units, presence of elaboration-control pragmas, and all + invocations in elaboration code. An order obtained using the static model is + guaranteed to be ABE problem-free, excluding dispatching calls and + access-to-subprogram types. + + The static model is the default model in GNAT. .. index:: SPARK elaboration model @@ -627,17 +665,23 @@ elaboration order and to diagnose elaboration problems. This is the most conservative of the three models and enforces the SPARK rules of elaboration as defined in the SPARK Reference Manual, section 7.7. The SPARK model is in effect only when a scenario and a target reside in a - region subject to SPARK_Mode On, otherwise the dynamic or static model is in - effect. + region subject to ``SPARK_Mode On``, otherwise the dynamic or static model + is in effect. -.. index:: Legacy elaboration model + The SPARK model is enabled with compiler switch :switch:`-gnatd.v`. -* *Legacy elaboration model* +.. index:: Legacy elaboration models + +* *Legacy elaboration models* In addition to the three elaboration models outlined above, GNAT provides the - elaboration model of pre-18.x versions referred to as `legacy elaboration - model`. The legacy elaboration model is enabled with compiler switch - :switch:`-gnatH`. + following legacy models: + + - `Legacy elaboration-checking model` available in pre-18.x versions of GNAT. + This model is enabled with compiler switch :switch:`-gnatH`. + + - `Legacy elaboration-order model` available in pre-20.x versions of GNAT. + This model is enabled with binder switch :switch:`-H`. .. index:: Relaxed elaboration mode @@ -645,812 +689,447 @@ The dynamic, legacy, and static models can be relaxed using compiler switch :switch:`-gnatJ`, making them more permissive. Note that in this mode, GNAT may not diagnose certain elaboration issues or install run-time checks. -.. _Common_Elaboration_Model_Traits": +.. _Mixing_Elaboration_Models: -Common Elaboration-model Traits -=============================== +Mixing Elaboration Models +========================= -All three GNAT models are able to detect elaboration problems related to -dispatching calls and a particular kind of ABE referred to as *guaranteed ABE*. +It is possible to mix units compiled with a different elaboration model, +however the following rules must be observed: -* *Dispatching calls* +* A client unit compiled with the dynamic model can only |with| a server unit + that meets at least one of the following criteria: - GNAT installs run-time checks for each primitive subprogram of each tagged - type defined in a partition on the assumption that a dispatching call - invoked at elaboration time will execute one of these primitives. As a - result, a dispatching call that executes a primitive whose body has not - been elaborated yet will raise exception ``Program_Error`` at run time. The - checks can be suppressed using pragma ``Suppress (Elaboration_Check)``. + - The server unit is compiled with the dynamic model. -* *Guaranteed ABE* + - The server unit is a GNAT implementation unit from the ``Ada``, ``GNAT``, + ``Interfaces``, or ``System`` hierarchies. - A guaranteed ABE arises when the body of a target is not elaborated early - enough, and causes all scenarios that directly execute the target to fail. + - The server unit has pragma ``Pure`` or ``Preelaborate``. - :: + - The client unit has an explicit ``Elaborate_All`` pragma for the server + unit. - package body Guaranteed_ABE is - function ABE return Integer; +These rules ensure that elaboration checks are not omitted. If the rules are +violated, the binder emits a warning: - Val : constant Integer := ABE; + :: - function ABE return Integer is - begin - ... - end ABE; - end Guaranteed_ABE; + warning: "x.ads" has dynamic elaboration checks and with's + warning: "y.ads" which has static elaboration checks - In the example above, the elaboration of ``Guaranteed_ABE``'s body elaborates - the declaration of ``Val``. This invokes function ``ABE``, however the body - of ``ABE`` has not been elaborated yet. GNAT emits similar diagnostics in all - three models: +The warnings can be suppressed by binder switch :switch:`-ws`. - :: +.. _ABE_Diagnostics: - 1. package body Guaranteed_ABE is - 2. function ABE return Integer; - 3. - 4. Val : constant Integer := ABE; - | - >>> warning: cannot call "ABE" before body seen - >>> warning: Program_Error will be raised at run time +ABE Diagnostics +=============== - 5. - 6. function ABE return Integer is - 7. begin - 8. ... - 9. end ABE; - 10. end Guaranteed_ABE; +GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios +that invoke internal targets, regardless of whether the dynamic, SPARK, or +static model is in effect. Note that GNAT emits warnings rather than hard errors whenever it encounters an elaboration problem. This is because the elaboration model in effect may be too -conservative, or a particular scenario may not be elaborated or executed due to -data and control flow. The warnings can be suppressed selectively with ``pragma -Warnigns (Off)`` or globally with compiler switch :switch:`-gnatwL`. - -.. _Dynamic_Elaboration_Model_in_GNAT: - -Dynamic Elaboration Model in GNAT -================================= - -The dynamic model assumes that all code within all units in a partition is -elaboration code. As a result, run-time checks are installed for each scenario -regardless of whether the target is internal or external. The checks can be -suppressed using pragma ``Suppress (Elaboration_Check)``. This behavior is -identical to that specified by the Ada Reference Manual. The following example -showcases run-time checks installed by GNAT to verify the elaboration state of -package ``Dynamic_Model``. - -:: +conservative, or a particular scenario may not be invoked due conditional +execution. The warnings can be suppressed selectively with ``pragma Warnings +(Off)`` or globally with compiler switch :switch:`-gnatwL`. - with Server; - package body Dynamic_Model is - procedure API is - begin - ... - end API; +A *guaranteed ABE* arises when the body of a target is not elaborated early +enough, and causes *all* scenarios that directly invoke the target to fail. - <check that the body of Server.Gen is elaborated> - package Inst is new Server.Gen; - - T : Server.Task_Type; - - begin - <check that the body of Server.Task_Type is elaborated> - - <check that the body of Server.Proc is elaborated> - Server.Proc; - end Dynamic_Model; - -The checks verify that the body of a target has been successfully elaborated -before a scenario activates, calls, or instantiates a target. - -Note that no scenario within package ``Dynamic_Model`` calls procedure ``API``. -In fact, procedure ``API`` may not be invoked by elaboration code within the -partition, however the dynamic model assumes that this can happen. + :: -The dynamic model emits very few diagnostics, but can make suggestions on -missing ``Elaborate`` and ``Elaborate_All`` pragmas for library-level -scenarios. This information is available when compiler switch :switch:`-gnatel` -is in effect. + package body Guaranteed_ABE is + function ABE return Integer; -:: + Val : constant Integer := ABE; - 1. with Server; - 2. package body Dynamic_Model is - 3. Val : constant Integer := Server.Func; - | - >>> info: call to "Func" during elaboration - >>> info: missing pragma "Elaborate_All" for unit "Server" + function ABE return Integer is + begin + ... + end ABE; + end Guaranteed_ABE; - 4. end Dynamic_Model; +In the example above, the elaboration of ``Guaranteed_ABE``'s body elaborates +the declaration of ``Val``. This invokes function ``ABE``, however the body of +``ABE`` has not been elaborated yet. GNAT emits the following diagnostic: -.. _Static_Elaboration_Model_in_GNAT: + :: -Static Elaboration Model in GNAT -================================ + 4. Val : constant Integer := ABE; + | + >>> warning: cannot call "ABE" before body seen + >>> warning: Program_Error will be raised at run time -In contrast to the dynamic model, the static model is more precise in its -analysis of elaboration code. The model makes a clear distinction between -internal and external targets, and resorts to different diagnostics and -run-time checks based on the nature of the target. +A *conditional ABE* arises when the body of a target is not elaborated early +enough, and causes *some* scenarios that directly invoke the target to fail. -* *Internal targets* + :: - The static model performs extensive diagnostics on scenarios which elaborate - or execute internal targets. The warnings resulting from these diagnostics - are enabled by default, but can be suppressed selectively with ``pragma - Warnings (Off)`` or globally with compiler switch :switch:`-gnatwL`. + 1. package body Conditional_ABE is + 2. procedure Force_Body is null; + 3. + 4. generic + 5. with function Func return Integer; + 6. package Gen is + 7. Val : constant Integer := Func; + 8. end Gen; + 9. + 10. function ABE return Integer; + 11. + 12. function Cause_ABE return Boolean is + 13. package Inst is new Gen (ABE); + 14. begin + 15. ... + 16. end Cause_ABE; + 17. + 18. Val : constant Boolean := Cause_ABE; + 19. + 20. function ABE return Integer is + 21. begin + 22. ... + 23. end ABE; + 24. + 25. Safe : constant Boolean := Cause_ABE; + 26. end Conditional_ABE; + +In the example above, the elaboration of package body ``Conditional_ABE`` +elaborates the declaration of ``Val``. This invokes function ``Cause_ABE``, +which instantiates generic unit ``Gen`` as ``Inst``. The elaboration of +``Inst`` invokes function ``ABE``, however the body of ``ABE`` has not been +elaborated yet. GNAT emits the following diagnostic: :: - 1. package body Static_Model is - 2. generic - 3. with function Func return Integer; - 4. package Gen is - 5. Val : constant Integer := Func; - 6. end Gen; - 7. - 8. function ABE return Integer; - 9. - 10. function Cause_ABE return Boolean is - 11. package Inst is new Gen (ABE); + 13. package Inst is new Gen (ABE); | - >>> warning: in instantiation at line 5 + >>> warning: in instantiation at line 7 >>> warning: cannot call "ABE" before body seen >>> warning: Program_Error may be raised at run time - >>> warning: body of unit "Static_Model" elaborated - >>> warning: function "Cause_ABE" called at line 16 - >>> warning: function "ABE" called at line 5, instance at line 11 - - 12. begin - 13. ... - 14. end Cause_ABE; - 15. - 16. Val : constant Boolean := Cause_ABE; - 17. - 18. function ABE return Integer is - 19. begin - 20. ... - 21. end ABE; - 22. end Static_Model; - - The example above illustrates an ABE problem within package ``Static_Model``, - which is hidden by several layers of indirection. The elaboration of package - body ``Static_Model`` elaborates the declaration of ``Val``. This invokes - function ``Cause_ABE``, which instantiates generic unit ``Gen`` as ``Inst``. - The elaboration of ``Inst`` invokes function ``ABE``, however the body of - ``ABE`` has not been elaborated yet. - -* *External targets* - - The static model installs run-time checks to verify the elaboration status - of server targets only when the scenario that elaborates or executes that - target is part of the elaboration code of the client unit. The checks can be - suppressed using pragma ``Suppress (Elaboration_Check)``. + >>> warning: body of unit "Conditional_ABE" elaborated + >>> warning: function "Cause_ABE" called at line 18 + >>> warning: function "ABE" called at line 7, instance at line 13 - :: +Note that the same ABE problem does not occur with the elaboration of +declaration ``Safe`` because the body of function ``ABE`` has already been +elaborated at that point. - with Server; - package body Static_Model is - generic - with function Func return Integer; - package Gen is - Val : constant Integer := Func; - end Gen; - - function Call_Func return Boolean is - <check that the body of Server.Func is elaborated> - package Inst is new Gen (Server.Func); - begin - ... - end Call_Func; - - Val : constant Boolean := Call_Func; - end Static_Model; +.. _SPARK_Diagnostics: - In the example above, the elaboration of package body ``Static_Model`` - elaborates the declaration of ``Val``. This invokes function ``Call_Func``, - which instantiates generic unit ``Gen`` as ``Inst``. The elaboration of - ``Inst`` invokes function ``Server.Func``. Since ``Server.Func`` is an - external target, GNAT installs a run-time check to verify that its body has - been elaborated. +SPARK Diagnostics +================= - In addition to checks, the static model installs implicit ``Elaborate`` and - ``Elaborate_All`` pragmas to guarantee safe elaboration use of server units. - This information is available when compiler switch :switch:`-gnatel` is in - effect. +GNAT enforces the SPARK rules of elaboration as defined in the SPARK Reference +Manual section 7.7 when compiler switch :switch:`-gnatd.v` is in effect. Note +that GNAT emits hard errors whenever it encounters a violation of the SPARK +rules. :: - 1. with Server; - 2. package body Static_Model is - 3. generic - 4. with function Func return Integer; - 5. package Gen is - 6. Val : constant Integer := Func; - 7. end Gen; - 8. - 9. function Call_Func return Boolean is - 10. package Inst is new Gen (Server.Func); - | - >>> info: instantiation of "Gen" during elaboration - >>> info: in instantiation at line 6 - >>> info: call to "Func" during elaboration - >>> info: in instantiation at line 6 - >>> info: implicit pragma "Elaborate_All" generated for unit "Server" - >>> info: body of unit "Static_Model" elaborated - >>> info: function "Call_Func" called at line 15 - >>> info: function "Func" called at line 6, instance at line 10 - - 11. begin - 12. ... - 13. end Call_Func; - 14. - 15. Val : constant Boolean := Call_Func; - | - >>> info: call to "Call_Func" during elaboration - - 16. end Static_Model; - - In the example above, the elaboration of package body ``Static_Model`` - elaborates the declaration of ``Val``. This invokes function ``Call_Func``, - which instantiates generic unit ``Gen`` as ``Inst``. The elaboration of - ``Inst`` invokes function ``Server.Func``. Since ``Server.Func`` is an - external target, GNAT installs an implicit ``Elaborate_All`` pragma for unit - ``Server``. The pragma guarantees that both the spec and body of ``Server``, - along with any additional dependencies that ``Server`` may require, are - elaborated prior to the body of ``Static_Model``. - -.. _SPARK_Elaboration_Model_in_GNAT: - -SPARK Elaboration Model in GNAT -=============================== - -The SPARK model is identical to the static model in its handling of internal -targets. The SPARK model, however, requires explicit ``Elaborate`` or -``Elaborate_All`` pragmas to be present in the program when a target is -external, and compiler switch :switch:`-gnatd.v` is in effect. - -:: - - 1. with Server; - 2. package body SPARK_Model with SPARK_Mode is - 3. Val : constant Integer := Server.Func; - | - >>> call to "Func" during elaboration in SPARK - >>> unit "SPARK_Model" requires pragma "Elaborate_All" for "Server" - >>> body of unit "SPARK_Model" elaborated - >>> function "Func" called at line 3 - - 4. end SPARK_Model; - -Legacy Elaboration Model in GNAT -================================ - -The legacy elaboration model is provided for compatibility with code bases -developed with pre-18.x versions of GNAT. It is similar in functionality to -the dynamic and static models of post-18.x version of GNAT, but may differ -in terms of diagnostics and run-time checks. The legacy elaboration model is -enabled with compiler switch :switch:`-gnatH`. + 1. with Server; + 2. package body SPARK_Diagnostics with SPARK_Mode is + 3. Val : constant Integer := Server.Func; + | + >>> call to "Func" during elaboration in SPARK + >>> unit "SPARK_Diagnostics" requires pragma "Elaborate_All" for "Server" + >>> body of unit "SPARK_Model" elaborated + >>> function "Func" called at line 3 -.. _Mixing_Elaboration_Models: + 4. end SPARK_Diagnostics; -Mixing Elaboration Models -========================= +.. _Elaboration_Circularities: -It is possible to mix units compiled with a different elaboration model, -however the following rules must be observed: +Elaboration Circularities +========================= -* A client unit compiled with the dynamic model can only |with| a server unit - that meets at least one of the following criteria: +An **elaboration circularity** occurs whenever the elaboration of a set of +units enters a deadlocked state, where each unit is waiting for another unit +to be elaborated. This situation may be the result of improper use of |with| +clauses, elaboration-control pragmas, or invocations in elaboration code. - - The server unit is compiled with the dynamic model. +The following example exhibits an elaboration circularity. - - The server unit is a GNAT implementation unit from the Ada, GNAT, - Interfaces, or System hierarchies. + :: - - The server unit has pragma ``Pure`` or ``Preelaborate``. + with B; pragma Elaborate (B); + package A is + end A; - - The client unit has an explicit ``Elaborate_All`` pragma for the server - unit. + :: -These rules ensure that elaboration checks are not omitted. If the rules are -violated, the binder emits a warning: + package B is + procedure Force_Body; + end B; -:: + :: - warning: "x.ads" has dynamic elaboration checks and with's - warning: "y.ads" which has static elaboration checks + with C; + package body B is + procedure Force_Body is null; -The warnings can be suppressed by binder switch :switch:`-ws`. + Elab : constant Integer := C.Func; + end B; -.. _Elaboration_Circularities: + :: -Elaboration Circularities -========================= + package C is + function Func return Integer; + end C; -If the binder cannot find an acceptable elaboration order, it outputs detailed -diagnostics describing an **elaboration circularity**. + :: -:: + with A; + package body C is + function Func return Integer is + begin + ... + end Func; + end C; - package Server is - function Func return Integer; - end Server; +The binder emits the following diagnostic: -:: + :: - with Client; - package body Server is - function Func return Integer is - begin - ... - end Func; - end Server; + error: Elaboration circularity detected + info: + info: Reason: + info: + info: unit "a (spec)" depends on its own elaboration + info: + info: Circularity: + info: + info: unit "a (spec)" has with clause and pragma Elaborate for unit "b (spec)" + info: unit "b (body)" is in the closure of pragma Elaborate + info: unit "b (body)" invokes a construct of unit "c (body)" at elaboration time + info: unit "c (body)" has with clause for unit "a (spec)" + info: + info: Suggestions: + info: + info: remove pragma Elaborate for unit "b (body)" in unit "a (spec)" + info: use the dynamic elaboration model (compiler switch -gnatE) -:: +The diagnostic consist of the following sections: - with Server; - package Client is - Val : constant Integer := Server.Func; - end Client; +* Reason -:: + This section provides a short explanation describing why the set of units + could not be ordered. - with Client; - procedure Main is begin null; end Main; +* Circularity -:: + This section enumerates the units comprising the deadlocked set, along with + their interdependencies. - error: elaboration circularity detected - info: "server (body)" must be elaborated before "client (spec)" - info: reason: implicit Elaborate_All in unit "client (spec)" - info: recompile "client (spec)" with -gnatel for full details - info: "server (body)" - info: must be elaborated along with its spec: - info: "server (spec)" - info: which is withed by: - info: "client (spec)" - info: "client (spec)" must be elaborated before "server (body)" - info: reason: with clause +* Suggestions -In the example above, ``Client`` must be elaborated prior to ``Main`` by virtue -of a |with| clause. The elaboration of ``Client`` invokes ``Server.Func``, and -static model generates an implicit ``Elaborate_All`` pragma for ``Server``. The -pragma implies that both the spec and body of ``Server``, along with any units -they |with|, must be elaborated prior to ``Client``. However, ``Server``'s body -|withs| ``Client``, implying that ``Client`` must be elaborated prior to -``Server``. The end result is that ``Client`` must be elaborated prior to -``Client``, and this leads to a circularity. + This section enumerates various tactics for eliminating the circularity. .. _Resolving_Elaboration_Circularities: Resolving Elaboration Circularities =================================== -When faced with an elaboration circularity, a programmer has several options -available. - -* *Fix the program* +The most desirable option from the point of view of long-term maintenance is to +rearrange the program so that the elaboration problems are avoided. One useful +technique is to place the elaboration code into separate child packages. +Another is to move some of the initialization code to explicitly invoked +subprograms, where the program controls the order of initialization explicitly. +Although this is the most desirable option, it may be impractical and involve +too much modification, especially in the case of complex legacy code. - The most desirable option from the point of view of long-term maintenance - is to rearrange the program so that the elaboration problems are avoided. - One useful technique is to place the elaboration code into separate child - packages. Another is to move some of the initialization code to explicitly - invoked subprograms, where the program controls the order of initialization - explicitly. Although this is the most desirable option, it may be impractical - and involve too much modification, especially in the case of complex legacy - code. +When faced with an elaboration circularity, the programmer should also consider +the tactics given in the suggestions section of the circularity diagnostic. +Depending on the units involved in the circularity, their |with| clauses, +purity, preelaborability, presence of elaboration-control pragmas and +invocations at elaboration time, the binder may suggest one or more of the +following tactics to eliminate the circularity: -* *Switch to more permissive elaboration model* +* Pragma Elaborate elimination - If the compilation was performed using the static model, enable the dynamic - model with compiler switch :switch:`-gnatE`. GNAT will no longer generate - implicit ``Elaborate`` and ``Elaborate_All`` pragmas, resulting in a behavior - identical to that specified by the Ada Reference Manual. The binder will - generate an executable program that may or may not raise ``Program_Error``, - and it is the programmer's responsibility to ensure that it does not raise - ``Program_Error``. + :: - If the compilation was performed using a post-18.x version of GNAT, consider - using the legacy elaboration model, in the following order: + remove pragma Elaborate for unit "..." in unit "..." - - Use the relaxed static elaboration model, with compiler switch - :switch:`-gnatJ`. + This tactic is suggested when the binder has determined that pragma + ``Elaborate``: - - Use the relaxed dynamic elaboration model, with compiler switches - :switch:`-gnatE` :switch:`-gnatJ`. + - Prevents a set of units from being elaborated. - - Use the legacy static elaboration model, with compiler switch - :switch:`-gnatH`. + - The removal of the pragma will not eliminate the semantic effects of the + pragma. In other words, the argument of the pragma will still be elaborated + prior to the unit containing the pragma. - - Use the legacy dynamic elaboration model, with compiler switches - :switch:`-gnatE` :switch:`-gnatH`. + - The removal of the pragma will enable the successful ordering of the units. -* *Suppress all elaboration checks* + The programmer should remove the pragma as advised, and rebuild the program. - The drawback of run-time checks is that they generate overhead at run time, - both in space and time. If the programmer is absolutely sure that a program - will not raise an elaboration-related ``Program_Error``, then using the - pragma ``Suppress (Elaboration_Check)`` globally (as a configuration pragma) - will eliminate all run-time checks. +* Pragma Elaborate_All elimination -* *Suppress elaboration checks selectively* + :: - If a scenario cannot possibly lead to an elaboration ``Program_Error``, - and the binder nevertheless complains about implicit ``Elaborate`` and - ``Elaborate_All`` pragmas that lead to elaboration circularities, it - is possible to suppress the generation of implicit ``Elaborate`` and - ``Elaborate_All`` pragmas, as well as run-time checks. Clearly this can - be unsafe, and it is the responsibility of the programmer to make sure - that the resulting program has no elaboration anomalies. Pragma - ``Suppress (Elaboration_Check)`` can be used with different levels of - granularity to achieve these effects. + remove pragma Elaborate_All for unit "..." in unit "..." - - *Target suppression* + This tactic is suggested when the binder has determined that pragma + ``Elaborate_All``: - When the pragma is placed in a declarative part, without a second argument - naming an entity, it will suppress implicit ``Elaborate`` and - ``Elaborate_All`` pragma generation, as well as run-time checks, on all - targets within the region. + - Prevents a set of units from being elaborated. - :: + - The removal of the pragma will not eliminate the semantic effects of the + pragma. In other words, the argument of the pragma along with its |with| + closure will still be elaborated prior to the unit containing the pragma. - package Range_Suppress is - pragma Suppress (Elaboration_Check); + - The removal of the pragma will enable the successful ordering of the units. - function Func return Integer; + The programmer should remove the pragma as advised, and rebuild the program. - generic - procedure Gen; +* Pragma Elaborate_All downgrade - pragma Unsuppress (Elaboration_Check); + :: - task type Tsk; - end Range_Suppress; + change pragma Elaborate_All for unit "..." to Elaborate in unit "..." - In the example above, a pair of Suppress/Unsuppress pragmas define a region - of suppression within package ``Range_Suppress``. As a result, no implicit - ``Elaborate`` and ``Elaborate_All`` pragmas, nor any run-time checks, will - be generated by callers of ``Func`` and instantiators of ``Gen``. Note that - task type ``Tsk`` is not within this region. + This tactic is always suggested with the pragma ``Elaborate_All`` elimination + tactic. It offers a different alernative of guaranteeing that the argument of + the pragma will still be elaborated prior to the unit containing the pragma. - An alternative to the region-based suppression is to use multiple - ``Suppress`` pragmas with arguments naming specific entities for which - elaboration checks should be suppressed: + The programmer should update the pragma as advised, and rebuild the program. - :: +* Pragma Elaborate_Body elimination - package Range_Suppress is - function Func return Integer; - pragma Suppress (Elaboration_Check, Func); + :: - generic - procedure Gen; - pragma Suppress (Elaboration_Check, Gen); + remove pragma Elaborate_Body in unit "..." - task type Tsk; - end Range_Suppress; + This tactic is suggested when the binder has determined that pragma + ``Elaborate_Body``: - - *Scenario suppression* + - Prevents a set of units from being elaborated. - When the pragma ``Suppress`` is placed in a declarative or statement - part, without an entity argument, it will suppress implicit ``Elaborate`` - and ``Elaborate_All`` pragma generation, as well as run-time checks, on - all scenarios within the region. + - The removal of the pragma will enable the successful ordering of the units. - :: + Note that the binder cannot determine whether the pragma is required for + other purposes, such as guaranteeing the initialization of a variable + declared in the spec by elaboration code in the body. - with Server; - package body Range_Suppress is - pragma Suppress (Elaboration_Check); + The programmer should remove the pragma as advised, and rebuild the program. - function Func return Integer is - begin - return Server.Func; - end Func; +* Use of pragma Restrictions - procedure Gen is - begin - Server.Proc; - end Gen; + :: - pragma Unsuppress (Elaboration_Check); + use pragma Restrictions (No_Entry_Calls_In_Elaboration_Code) - task body Tsk is - begin - Server.Proc; - end Tsk; - end Range_Suppress; - - In the example above, a pair of Suppress/Unsuppress pragmas define a region - of suppression within package body ``Range_Suppress``. As a result, the - calls to ``Server.Func`` in ``Func`` and ``Server.Proc`` in ``Gen`` will - not generate any implicit ``Elaborate`` and ``Elaborate_All`` pragmas or - run-time checks. - -.. _Resolving_Task_Issues: - -Resolving Task Issues -===================== - -The model of execution in Ada dictates that elaboration must first take place, -and only then can the main program be started. Tasks which are activated during -elaboration violate this model and may lead to serious concurrent problems at -elaboration time. - -A task can be activated in two different ways: - -* The task is created by an allocator in which case it is activated immediately - after the allocator is evaluated. - -* The task is declared at the library level or within some nested master in - which case it is activated before starting execution of the statement - sequence of the master defining the task. - -Since the elaboration of a partition is performed by the environment task -servicing that partition, any tasks activated during elaboration may be in -a race with the environment task, and lead to unpredictable state and behavior. -The static model seeks to avoid such interactions by assuming that all code in -the task body is executed at elaboration time, if the task was activated by -elaboration code. - -:: - - package Decls is - task Lib_Task is - entry Start; - end Lib_Task; - - type My_Int is new Integer; - - function Ident (M : My_Int) return My_Int; - end Decls; - -:: - - with Utils; - package body Decls is - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; - - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; - end Decls; - -:: - - with Decls; - package Utils is - procedure Put_Val (Arg : Decls.My_Int); - end Utils; - -:: - - with Ada.Text_IO; use Ada.Text_IO; - package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin - Put_Line (Arg'Img); - end Put_Val; - end Utils; - -:: - - with Decls; - procedure Main is - begin - Decls.Lib_Task.Start; - end Main; - -When the above example is compiled with the static model, an elaboration -circularity arises: - -:: - - error: elaboration circularity detected - info: "decls (body)" must be elaborated before "decls (body)" - info: reason: implicit Elaborate_All in unit "decls (body)" - info: recompile "decls (body)" with -gnatel for full details - info: "decls (body)" - info: must be elaborated along with its spec: - info: "decls (spec)" - info: which is withed by: - info: "utils (spec)" - info: which is withed by: - info: "decls (body)" - -In the above example, ``Decls`` must be elaborated prior to ``Main`` by virtue -of a with clause. The elaboration of ``Decls`` activates task ``Lib_Task``. The -static model conservatibely assumes that all code within the body of -``Lib_Task`` is executed, and generates an implicit ``Elaborate_All`` pragma -for ``Units`` due to the call to ``Utils.Put_Val``. The pragma implies that -both the spec and body of ``Utils``, along with any units they |with|, -must be elaborated prior to ``Decls``. However, ``Utils``'s spec |withs| -``Decls``, implying that ``Decls`` must be elaborated before ``Utils``. The end -result is that ``Utils`` must be elaborated prior to ``Utils``, and this -leads to a circularity. - -In reality, the example above will not exhibit an ABE problem at run time. -When the body of task ``Lib_Task`` is activated, execution will wait for entry -``Start`` to be accepted, and the call to ``Utils.Put_Val`` will not take place -at elaboration time. Task ``Lib_Task`` will resume its execution after the main -program is executed because ``Main`` performs a rendezvous with -``Lib_Task.Start``, and at that point all units have already been elaborated. -As a result, the static model may seem overly conservative, partly because it -does not take control and data flow into account. - -When faced with a task elaboration circularity, a programmer has several -options available: - -* *Use the dynamic model* - - The dynamic model does not generate implicit ``Elaborate`` and - ``Elaborate_All`` pragmas. Instead, it will install checks prior to every - call in the example above, thus verifying the successful elaboration of - ``Utils.Put_Val`` in case the call to it takes place at elaboration time. - The dynamic model is enabled with compiler switch :switch:`-gnatE`. + This tactic is suggested when the binder has determined that a task + activation at elaboration time: -* *Isolate the tasks* + - Prevents a set of units from being elaborated. - Relocating tasks in their own separate package could decouple them from - dependencies that would otherwise cause an elaboration circularity. The - example above can be rewritten as follows: + Note that the binder cannot determine with certainty whether the task will + block at elaboration time. - :: + The programmer should create a configuration file, place the pragma within, + update the general compilation arguments, and rebuild the program. - package Decls1 is -- new - task Lib_Task is - entry Start; - end Lib_Task; - end Decls1; +* Use of dynamic elaboration model :: - with Utils; - package body Decls1 is -- new - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; - end Decls1; + use the dynamic elaboration model (compiler switch -gnatE) - :: + This tactic is suggested when the binder has determined that an invocation at + elaboration time: - package Decls2 is -- new - type My_Int is new Integer; - function Ident (M : My_Int) return My_Int; - end Decls2; + - Prevents a set of units from being elaborated. - :: + - The use of the dynamic model will enable the successful ordering of the + units. - with Utils; - package body Decls2 is -- new - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; - end Decls2; + The programmer has two options: - :: + - Determine the units involved in the invocation using the detailed + invocation information, and add compiler switch :switch:`-gnatE` to the + compilation arguments of selected files only. This approach will yield + safer elaboration orders compared to the other option because it will + minimize the opportunities presented to the dynamic model for ignoring + invocations. - with Decls2; - package Utils is - procedure Put_Val (Arg : Decls2.My_Int); - end Utils; + - Add compiler switch :switch:`-gnatE` to the general compilation arguments. + +* Use of detailed invocation information :: - with Ada.Text_IO; use Ada.Text_IO; - package body Utils is - procedure Put_Val (Arg : Decls2.My_Int) is - begin - Put_Line (Arg'Img); - end Put_Val; - end Utils; + use detailed invocation information (compiler switch -gnatd_F) - :: + This tactic is always suggested with the use of the dynamic model tactic. It + causes the circularity section of the circularity diagnostic to describe the + flow of elaboration code from a unit to a unit, enumerating all such paths in + the process. - with Decls1; - procedure Main is - begin - Decls1.Lib_Task.Start; - end Main; - -* *Declare the tasks* + The programmer should analyze this information to determine which units + should be compiled with the dynamic model. - The original example uses a single task declaration for ``Lib_Task``. An - explicit task type declaration and a properly placed task object could avoid - the dependencies that would otherwise cause an elaboration circularity. The - example can be rewritten as follows: +* Forced-dependency elimination :: - package Decls is - task type Lib_Task is -- new - entry Start; - end Lib_Task; + remove the dependency of unit "..." on unit "..." from the argument of switch -f - type My_Int is new Integer; + This tactic is suggested when the binder has determined that a dependency + present in the forced-elaboration-order file indicated by binder switch + :switch:`-f`: - function Ident (M : My_Int) return My_Int; - end Decls; + - Prevents a set of units from being elaborated. - :: + - The removal of the dependency will enable the successful ordering of the + units. - with Utils; - package body Decls is - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; + The programmer should edit the forced-elaboration-order file, remove the + dependency, and rebind the program. - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; - end Decls; +* All forced-dependency elimination :: - with Decls; - package Utils is - procedure Put_Val (Arg : Decls.My_Int); - end Utils; + remove switch -f - :: + This tactic is suggested in case editing the forced-elaboration-order file is + not an option. - with Ada.Text_IO; use Ada.Text_IO; - package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin - Put_Line (Arg'Img); - end Put_Val; - end Utils; - - :: + The programmer should remove binder switch :switch:`-f` from the binder + arguments, and rebind. - with Decls; - package Obj_Decls is -- new - Task_Obj : Decls.Lib_Task; - end Obj_Decls; +* Multiple-circularities diagnostic :: - with Obj_Decls; - procedure Main is - begin - Obj_Decls.Task_Obj.Start; -- new - end Main; + diagnose all circularities (binder switch -d_C) -* *Use restriction No_Entry_Calls_In_Elaboration_Code* + By default, the binder will diagnose only the highest-precedence circularity. + If the program contains multiple circularities, the binder will suggest the + use of binder switch :switch:`-d_C` in order to obtain the diagnostics of all + circularities. - The issue exhibited in the original example under this section revolves - around the body of ``Lib_Task`` blocking on an accept statement. There is - no rule to prevent elaboration code from performing entry calls, however in - practice this is highly unusual. In addition, the pattern of starting tasks - at elaboration time and then immediately blocking on accept or select - statements is quite common. + The programmer should add binder switch :switch:`-d_C` to the binder + arguments, and rebind. - If a programmer knows that elaboration code will not perform any entry - calls, then the programmer can indicate that the static model should not - process the remainder of a task body once an accept or select statement has - been encountered. This behavior can be specified by a configuration pragma: +If none of the tactics suggested by the binder eliminate the elaboration +circularity, the programmer should consider using one of the legacy elaboration +models, in the following order: - :: +* Use the pre-20.x legacy elaboration-order model, with binder switch + :switch:`-H`. + +* Use both pre-18.x and pre-20.x legacy elaboration models, with compiler + switch :switch:`-gnatH` and binder switch :switch:`-H`. - pragma Restrictions (No_Entry_Calls_In_Elaboration_Code); +* Use the relaxed static-elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ` and binder switch :switch:`-H`. - In addition to the change in behavior with respect to task bodies, the - static model will verify that no entry calls take place at elaboration time. +* Use the relaxed dynamic-elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ` :switch:`-gnatE` and binder switch + :switch:`-H`. .. _Elaboration_Related_Compiler_Switches: @@ -1465,13 +1144,17 @@ the elaboration order chosen by the binder. :switch:`-gnatE` Dynamic elaboration checking mode enabled - When this switch is in effect, GNAT activates the dynamic elaboration model. + When this switch is in effect, GNAT activates the dynamic model. .. index:: -gnatel (gnat) :switch:`-gnatel` Turn on info messages on generated Elaborate[_All] pragmas + This switch is only applicable to the pre-20.x legacy elaboration models. + The post-20.x elaboration model no longer relies on implicitly generated + ``Elaborate`` and ``Elaborate_All`` pragmas to order units. + When this switch is in effect, GNAT will emit the following supplementary information depending on the elaboration model in effect. @@ -1482,7 +1165,7 @@ the elaboration order chosen by the binder. - *Static model* - GNAT will indicate all scenarios executed during elaboration. In addition, + GNAT will indicate all scenarios invoked during elaboration. In addition, it will provide detailed traceback when an implicit ``Elaborate`` or ``Elaborate_All`` pragma is generated. @@ -1615,29 +1298,24 @@ options: as their origins. Elaboration warnings are enabled with compiler switch :switch:`-gnatwl`. -* Use switch :switch:`-gnatel` to obtain messages on generated implicit - ``Elaborate`` and ``Elaborate_All`` pragmas. The trace information could - indicate why a server unit must be elaborated prior to a client unit. - -* If the warnings produced by the static model indicate that a task is - involved, consider the options in section `Resolving Task Issues`_. +* Cosider the tactics given in the suggestions section of the circularity + diagnostic. * If none of the steps outlined above resolve the circularity, use a more permissive elaboration model, in the following order: - - Use the dynamic elaboration model, with compiler switch :switch:`-gnatE`. - - - Use the legacy static elaboration model, with compiler switch - :switch:`-gnatH`. + - Use the pre-20.x legacy elaboration-order model, with binder switch + :switch:`-H`. - - Use the legacy dynamic elaboration model, with compiler switches - :switch:`-gnatH` :switch:`-gnatE`. + - Use both pre-18.x and pre-20.x legacy elaboration models, with compiler + switch :switch:`-gnatH` and binder switch :switch:`-H`. - - Use the relaxed legacy static elaboration model, with compiler switches - :switch:`-gnatH` :switch:`-gnatJ`. + - Use the relaxed static elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ` and binder switch :switch:`-H`. - - Use the relaxed legacy dynamic elaboration model, with compiler switches - :switch:`-gnatH` :switch:`-gnatJ` :switch:`-gnatE`. + - Use the relaxed dynamic elaboration model, with compiler switches + :switch:`-gnatH` :switch:`-gnatJ` :switch:`-gnatE` and binder switch + :switch:`-H`. .. _Inspecting_the_Chosen_Elaboration_Order: @@ -1650,128 +1328,128 @@ elaboration order appears as a sequence of calls to ``Elab_Body`` and ``Elab_Spec``, interspersed with assignments to `Exxx` which indicates that a particular unit is elaborated. For example: -:: - - System.Soft_Links'Elab_Body; - E14 := True; - System.Secondary_Stack'Elab_Body; - E18 := True; - System.Exception_Table'Elab_Body; - E24 := True; - Ada.Io_Exceptions'Elab_Spec; - E67 := True; - Ada.Tags'Elab_Spec; - Ada.Streams'Elab_Spec; - E43 := True; - Interfaces.C'Elab_Spec; - E69 := True; - System.Finalization_Root'Elab_Spec; - E60 := True; - System.Os_Lib'Elab_Body; - E71 := True; - System.Finalization_Implementation'Elab_Spec; - System.Finalization_Implementation'Elab_Body; - E62 := True; - Ada.Finalization'Elab_Spec; - E58 := True; - Ada.Finalization.List_Controller'Elab_Spec; - E76 := True; - System.File_Control_Block'Elab_Spec; - E74 := True; - System.File_Io'Elab_Body; - E56 := True; - Ada.Tags'Elab_Body; - E45 := True; - Ada.Text_Io'Elab_Spec; - Ada.Text_Io'Elab_Body; - E07 := True; + :: + + System.Soft_Links'Elab_Body; + E14 := True; + System.Secondary_Stack'Elab_Body; + E18 := True; + System.Exception_Table'Elab_Body; + E24 := True; + Ada.Io_Exceptions'Elab_Spec; + E67 := True; + Ada.Tags'Elab_Spec; + Ada.Streams'Elab_Spec; + E43 := True; + Interfaces.C'Elab_Spec; + E69 := True; + System.Finalization_Root'Elab_Spec; + E60 := True; + System.Os_Lib'Elab_Body; + E71 := True; + System.Finalization_Implementation'Elab_Spec; + System.Finalization_Implementation'Elab_Body; + E62 := True; + Ada.Finalization'Elab_Spec; + E58 := True; + Ada.Finalization.List_Controller'Elab_Spec; + E76 := True; + System.File_Control_Block'Elab_Spec; + E74 := True; + System.File_Io'Elab_Body; + E56 := True; + Ada.Tags'Elab_Body; + E45 := True; + Ada.Text_Io'Elab_Spec; + Ada.Text_Io'Elab_Body; + E07 := True; Note also binder switch :switch:`-l`, which outputs the chosen elaboration order and provides a more readable form of the above: -:: - - ada (spec) - interfaces (spec) - system (spec) - system.case_util (spec) - system.case_util (body) - system.concat_2 (spec) - system.concat_2 (body) - system.concat_3 (spec) - system.concat_3 (body) - system.htable (spec) - system.parameters (spec) - system.parameters (body) - system.crtl (spec) - interfaces.c_streams (spec) - interfaces.c_streams (body) - system.restrictions (spec) - system.restrictions (body) - system.standard_library (spec) - system.exceptions (spec) - system.exceptions (body) - system.storage_elements (spec) - system.storage_elements (body) - system.secondary_stack (spec) - system.stack_checking (spec) - system.stack_checking (body) - system.string_hash (spec) - system.string_hash (body) - system.htable (body) - system.strings (spec) - system.strings (body) - system.traceback (spec) - system.traceback (body) - system.traceback_entries (spec) - system.traceback_entries (body) - ada.exceptions (spec) - ada.exceptions.last_chance_handler (spec) - system.soft_links (spec) - system.soft_links (body) - ada.exceptions.last_chance_handler (body) - system.secondary_stack (body) - system.exception_table (spec) - system.exception_table (body) - ada.io_exceptions (spec) - ada.tags (spec) - ada.streams (spec) - interfaces.c (spec) - interfaces.c (body) - system.finalization_root (spec) - system.finalization_root (body) - system.memory (spec) - system.memory (body) - system.standard_library (body) - system.os_lib (spec) - system.os_lib (body) - system.unsigned_types (spec) - system.stream_attributes (spec) - system.stream_attributes (body) - system.finalization_implementation (spec) - system.finalization_implementation (body) - ada.finalization (spec) - ada.finalization (body) - ada.finalization.list_controller (spec) - ada.finalization.list_controller (body) - system.file_control_block (spec) - system.file_io (spec) - system.file_io (body) - system.val_uns (spec) - system.val_util (spec) - system.val_util (body) - system.val_uns (body) - system.wch_con (spec) - system.wch_con (body) - system.wch_cnv (spec) - system.wch_jis (spec) - system.wch_jis (body) - system.wch_cnv (body) - system.wch_stw (spec) - system.wch_stw (body) - ada.tags (body) - ada.exceptions (body) - ada.text_io (spec) - ada.text_io (body) - text_io (spec) - gdbstr (body) + :: + + ada (spec) + interfaces (spec) + system (spec) + system.case_util (spec) + system.case_util (body) + system.concat_2 (spec) + system.concat_2 (body) + system.concat_3 (spec) + system.concat_3 (body) + system.htable (spec) + system.parameters (spec) + system.parameters (body) + system.crtl (spec) + interfaces.c_streams (spec) + interfaces.c_streams (body) + system.restrictions (spec) + system.restrictions (body) + system.standard_library (spec) + system.exceptions (spec) + system.exceptions (body) + system.storage_elements (spec) + system.storage_elements (body) + system.secondary_stack (spec) + system.stack_checking (spec) + system.stack_checking (body) + system.string_hash (spec) + system.string_hash (body) + system.htable (body) + system.strings (spec) + system.strings (body) + system.traceback (spec) + system.traceback (body) + system.traceback_entries (spec) + system.traceback_entries (body) + ada.exceptions (spec) + ada.exceptions.last_chance_handler (spec) + system.soft_links (spec) + system.soft_links (body) + ada.exceptions.last_chance_handler (body) + system.secondary_stack (body) + system.exception_table (spec) + system.exception_table (body) + ada.io_exceptions (spec) + ada.tags (spec) + ada.streams (spec) + interfaces.c (spec) + interfaces.c (body) + system.finalization_root (spec) + system.finalization_root (body) + system.memory (spec) + system.memory (body) + system.standard_library (body) + system.os_lib (spec) + system.os_lib (body) + system.unsigned_types (spec) + system.stream_attributes (spec) + system.stream_attributes (body) + system.finalization_implementation (spec) + system.finalization_implementation (body) + ada.finalization (spec) + ada.finalization (body) + ada.finalization.list_controller (spec) + ada.finalization.list_controller (body) + system.file_control_block (spec) + system.file_io (spec) + system.file_io (body) + system.val_uns (spec) + system.val_util (spec) + system.val_util (body) + system.val_uns (body) + system.wch_con (spec) + system.wch_con (body) + system.wch_cnv (spec) + system.wch_jis (spec) + system.wch_jis (body) + system.wch_cnv (body) + system.wch_stw (spec) + system.wch_stw (body) + ada.tags (body) + ada.exceptions (body) + ada.text_io (spec) + ada.text_io (body) + text_io (spec) + gdbstr (body) 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 9cbdb15..de348e9 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -3972,7 +3972,7 @@ execution of this erroneous program: :: - $ gnatmem [ switches ] user_program + $ gnatmem [ switches ] [ DEPTH ] user_program The program must have been linked with the instrumented version of the allocation and deallocation routines. This is done by linking with the @@ -4062,15 +4062,16 @@ execution of this erroneous program: memory leaks. Omits statistical information. - .. index:: N switch (gnatmem) + .. index:: DEPTH switch (gnatmem) - :samp:`{N}` - ``N`` is an integer literal (usually between 1 and 10) which controls the - depth of the backtraces defining allocation root. The default value for - N is 1. The deeper the backtrace, the more precise the localization of + :samp:`{DEPTH}` + ``DEPTH`` is an integer literal (usually between 1 and 10) which controls + the depth of the backtraces defining allocation root. The default value for + DEPTH is 1. The deeper the backtrace, the more precise the localization of the root. Note that the total number of roots can depend on this - parameter. This parameter must be specified *before* the name of the - executable to be analyzed, to avoid ambiguity. + parameter, in other words there may be more roots when the requested + backtrace depth is higher. This parameter must be specified *before* the + name of the executable to be analyzed, to avoid ambiguity. .. index:: -b (gnatmem) diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst index 53904b1..fc39214 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst @@ -1214,7 +1214,7 @@ The following switches are available: :samp:`f` By default, gnathtml will generate html links only for global entities - ('with'ed units, global variables and types,...). If you specify + ('with'ed units, global variables and types,...). If you specify :switch:`-f` on the command line, then links will be generated for local entities too. @@ -1310,7 +1310,7 @@ Alternatively, you may run the script using the following command line: ``gnat2xml`` is a project-aware tool (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of - the project-related switches). The project file package that can specify + the project-related switches). The project file package that can specify ``gnat2xml`` switches is named ``gnat2xml``. .. _Switches_for_``gnat2xml``: @@ -1780,7 +1780,7 @@ Alternatively, you may run the script using the following command line: ``gnatcheck`` is a project-aware tool (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of - the project-related switches). The project file package that can specify + the project-related switches). The project file package that can specify ``gnatcheck`` switches is named ``Check``. For full details, plese refer to :title:`GNATcheck Reference Manual`. @@ -1804,11 +1804,11 @@ Alternatively, you may run the script using the following command line: for computing various program metrics. It takes an Ada source file as input and generates a file containing the metrics data as output. Various switches control which - metrics are computed and output. + metrics are reported. ``gnatmetric`` is a project-aware tool (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of - the project-related switches). The project file package that can specify + the project-related switches). The project file package that can specify ``gnatmetric`` switches is named ``Metrics``. The ``gnatmetric`` command has the form @@ -1921,9 +1921,9 @@ Alternatively, you may run the script using the following command line: .. index:: --short-file-names (gnatmetric) :switch:`--short-file-names` - Use 'short' source file names in the output. (The ``gnatmetric`` + Use 'short' source file names in the output. (The ``gnatmetric`` output includes the name(s) of the Ada source file(s) from which the - metrics are computed. By default each name includes the absolute + metrics are computed. By default each name includes the absolute path. The :switch:`--short-file-names` switch causes ``gnatmetric`` to exclude all directory information from the file names that are output.) @@ -1980,12 +1980,11 @@ Alternatively, you may run the script using the following command line: Specifying a set of metrics to compute -------------------------------------- - By default all the metrics are computed and reported. The switches - described in this subsection allow you to control, on an individual - basis, whether metrics are computed and reported. If at least one - positive metric switch is specified (that is, a switch that defines - that a given metric or set of metrics is to be computed), then only - explicitly specified metrics are reported. + By default all the metrics are reported. The switches described in this + subsection allow you to control, on an individual basis, whether metrics are + reported. If at least one positive metric switch is specified (that is, a + switch that defines that a given metric or set of metrics is to be computed), + then only explicitly specified metrics are reported. .. _Line_Metrics_Control: @@ -2023,7 +2022,7 @@ Alternatively, you may run the script using the following command line: code lines in bodies. You can use the following switches to select the specific line metrics - to be computed and reported. + to be reported. .. index:: --lines (gnatmetric) @@ -2089,10 +2088,9 @@ Alternatively, you may run the script using the following command line: :switch:`--lines-average` - Report the average number of code lines in subprogram bodies, task - bodies, entry bodies and statement sequences in package bodies. The - metric is computed and reported for the whole set of processed Ada - sources only. + Report the average number of code lines in subprogram bodies, task bodies, + entry bodies and statement sequences in package bodies. The metric is + reported for the whole set of processed Ada sources only. :switch:`--no-lines-average` @@ -2173,7 +2171,7 @@ Alternatively, you may run the script using the following command line: declarations. It is the total number of types that can be referenced from outside this compilation unit, plus the number of types from all the visible parts of all the visible generic - packages. Generic formal types are not counted. Only types, not + packages. Generic formal types are not counted. Only types, not subtypes, are included. Along with the total number of public types, the following @@ -2193,14 +2191,14 @@ Alternatively, you may run the script using the following command line: * *All types* This metric is computed for any compilation unit. It is equal to the total number of the declarations of different types given in - the compilation unit. The private and the corresponding full type + the compilation unit. The private and the corresponding full type declaration are counted as one type declaration. Incomplete type declarations and generic formal types are not counted. No distinction is made among different kinds of types (abstract, - private etc.); the total number of types is computed and reported. + private etc.); the total number of types is reported. - By default, all the syntax metrics are computed and reported. You can - use the following switches to select specific syntax metrics. + By default, all the syntax metrics are reported. You can use the following + switches to select specific syntax metrics. .. index:: --syntax (gnatmetric) @@ -2311,7 +2309,7 @@ Alternatively, you may run the script using the following command line: According to McCabe, both control statements and short-circuit control forms should be taken into account when computing cyclomatic - complexity. For Ada 2012 we have also take into account conditional + complexity. For Ada 2012 we have also take into account conditional expressions and quantified expressions. For each body, we compute three metric values: @@ -2364,9 +2362,8 @@ Alternatively, you may run the script using the following command line: code of assertions and predicates (that is, subprogram preconditions and postconditions, subtype predicates and type invariants) is also skipped. - By default, all the complexity metrics are computed and reported. - For more fine-grained control you can use - the following switches: + By default, all the complexity metrics are reported. For more fine-grained + control you can use the following switches: .. index:: --complexity (gnatmetric) @@ -2408,8 +2405,7 @@ Alternatively, you may run the script using the following command line: :switch:`--complexity-average` Report the average McCabe Cyclomatic Complexity for all the subprogram bodies, task bodies, entry bodies and statement sequences in package bodies. - The metric is computed and reported for whole set of processed Ada sources - only. + The metric is reported for whole set of processed Ada sources only. :switch:`--no-complexity-average` @@ -2623,8 +2619,8 @@ Alternatively, you may run the script using the following command line: by invoking ``gnatmetric`` with the corresponding project file and with the :switch:`-U` option. - By default, all the coupling metrics are disabled. You can use the following - switches to specify the coupling metrics to be computed and reported: + By default, all the coupling metrics are reported. You can use the following + switches to select specific syntax metrics. .. index:: --tagged-coupling (gnatmetric) .. index:: --hierarchy-coupling (gnatmetric) @@ -2854,14 +2850,14 @@ Alternatively, you may run the script using the following command line: of ``gnatpp``, which replaces the ASIS-based version. The ``gnatpp`` tool is a utility for source reformatting / pretty - printing. It takes an Ada source file as input and generates a - reformatted version as output. You can specify various style + printing. It takes an Ada source file as input and generates a + reformatted version as output. You can specify various style directives via switches; e.g., identifier case conventions, rules of indentation, and comment layout. ``gnatpp`` is a project-aware tool (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of - the project-related switches). The project file package that can specify + the project-related switches). The project file package that can specify ``gnatpp`` switches is named ``Pretty_Printer``. ``gnatpp`` cannot process sources that contain preprocessing @@ -3019,7 +3015,7 @@ Alternatively, you may run the script using the following command line: .. index:: --enum-upper-case (gnatpp) :switch:`--enum-upper-case` - Enumeration literals are in upper case. Overrides -n casing + Enumeration literals are in upper case. Overrides -n casing setting. .. index:: --enum-lower-case (gnatpp) @@ -3133,7 +3129,7 @@ Alternatively, you may run the script using the following command line: compatible. This group of ``gnatpp`` switches controls the layout of comments and - complex syntactic constructs. See :ref:`Formatting_Comments` for details + complex syntactic constructs. See :ref:`Formatting_Comments` for details on their effect. @@ -3248,6 +3244,20 @@ Alternatively, you may run the script using the following command line: :switch:`--preserve-line-breaks` Preserve line breaks in the input, to the extent possible. + By default, line breaks are also inserted at appropriate + places. + + .. index:: --source-line-breaks (gnatpp) + + :switch:`--source-line-breaks` + Keep the line breaks from the source; do not insert or delete any + line breaks. + + .. index:: --spaces-only (gnatpp) + + :switch:`--spaces-only` + Disable all formatting except for inserting and removing spaces. + This implies --source-line-breaks. The ``--comments`` switches are compatible with one another, except that the ``--comments-unchanged`` switch disables all other comment @@ -3337,12 +3347,6 @@ Alternatively, you may run the script using the following command line: '(' and ':'. This also turns off alignment. - .. index:: --ff-after-pragma-page (gnatpp) - - :switch:`--ff-after-pragma-page` - Insert a Form Feed character after a pragma Page. - - .. index:: --call_threshold (gnatpp) :switch:`--call_threshold={nnn}` @@ -3742,10 +3746,10 @@ Alternatively, you may run the script using the following command line: the same line. A whole-line comment is indented according to the surrounding code, - with some exceptions. Comments that start in column 1 are kept - there. If possible, comments are not moved so far to the right that - the maximum line length is exceeded. The ``--comments-unchanged`` - option turns off comment formatting. Special-form comments such as + with some exceptions. Comments that start in column 1 are kept + there. If possible, comments are not moved so far to the right that + the maximum line length is exceeded. The ``--comments-unchanged`` + option turns off comment formatting. Special-form comments such as SPARK-style ``--#...`` are left alone. For an end-of-line comment, ``gnatpp`` tries to leave the same @@ -3770,7 +3774,7 @@ Alternatively, you may run the script using the following command line: are formatted according to the ``--comments-gnat-beginning`` and ``--comments-fill`` switches; other formatting switches are ignored. For example, ``--comments-only --comments-fill`` means to fill comment - paragraphs, and do nothing else. Likewise, ``--comments-only + paragraphs, and do nothing else. Likewise, ``--comments-only --comments-gnat-beginning`` ensures comments start with at least two spaces after ``--``, and ``--comments-only --comments-gnat-beginning --comments-fill`` does both. If ``--comments-only`` is given without @@ -3787,11 +3791,11 @@ Alternatively, you may run the script using the following command line: the same casing as the corresponding defining identifier. You control the casing for defining occurrences via the ``--name...`` - switches. With ``--name-case-as-declared``, which is the default, + switches. With ``--name-case-as-declared``, which is the default, defining occurrences appear exactly as in the source file where they - are declared. The other values for this switch -- + are declared. The other values for this switch -- ``--name-upper-case``, ``--name-lower-case``, ``--name-mixed-case`` - -- result in upper, lower, or mixed case, respectively. If + -- result in upper, lower, or mixed case, respectively. If ``gnatpp`` changes the casing of a defining occurrence, it analogously changes the casing of all the usage occurrences of this name. @@ -3799,7 +3803,7 @@ Alternatively, you may run the script using the following command line: If the defining occurrence of a name is not in the source compilation unit currently being processed by ``gnatpp``, the casing of each reference to this name is changed according to the switch (subject to - the dictionary file mechanism described below). Thus ``gnatpp`` acts + the dictionary file mechanism described below). Thus ``gnatpp`` acts as though the switch had affected the casing for the defining occurrence of the name. @@ -3836,7 +3840,7 @@ Alternatively, you may run the script using the following command line: ``-n`` switch or explicit dictionary files. For example, by default the names ``Ada.Text_IO`` and ``GNAT.OS_Lib`` will appear as just shown, even in the presence of - a ``--name-upper-case`` switch. To ensure that even + a ``--name-upper-case`` switch. To ensure that even such names are rendered in uppercase, additionally supply the --dictionary=- switch (or else place these names in upper case in a dictionary file). @@ -3933,6 +3937,67 @@ Alternatively, you may run the script using the following command line: Name2_NAME3_Name4 := Name4_NAME3_Name2 > NAME1; end Test; + .. _Preprocessor_directives: + + Preprocessor Directives + ^^^^^^^^^^^^^^^^^^^^^^^ + + ``gnatpp`` has some support for preprocessor directives. + You can use preprocessor symbols, as in ``$symbol``. + In addition, you can use conditional compilation, + so long as the program text is syntactically legal Ada code + after removing all the preprocessor directives (lines starting + with ``#``). For example, ``gnatpp`` can format the following: + + .. code-block:: ada + + package P is + #IF SOMETHING + X : constant Integer := 123; + #ELSE + X : constant Integer := 456; + #END IF; + end P; + + which will be formatted as if it were: + + .. code-block:: ada + + package P is + X : constant Integer := 123; + X : constant Integer := 456; + end P; + + except that the ``#`` lines will be preserved. + However, ``gnatpp`` cannot format the following: + + .. code-block:: ada + + procedure P is + begin + #IF SOMETHING + if X = 0 then + #ELSE + if X = 1 then + #END IF; + null; + end if; + end P; + + because removing the ``#`` lines gives: + + .. code-block:: ada + + procedure P is + begin + if X = 0 then + if X = 1 then + null; + end if; + end P; + + which is not syntactically legal. + Legacy Switches ^^^^^^^^^^^^^^^ @@ -4062,11 +4127,6 @@ Alternatively, you may run the script using the following command line: :switch:`-cl{nnn}` :switch:`--indent-continuation={nnn}` - .. index:: -ff (gnatpp) - - :switch:`-ff` - :switch:`--ff-after-pragma-page` - .. index:: -pipe (gnatpp) :switch:`-pipe` @@ -4690,7 +4750,7 @@ Alternatively, you may run the script using the following command line: :switch:`--subdir={dirname}` Test packages are placed in a subdirectory of the corresponding source directory, with the name ``dirname``. Thus, each set of unit tests is located - in a subdirectory of the code under test. If the sources are in separate + in a subdirectory of the code under test. If the sources are in separate directories, each source directory has a test subdirectory named ``dirname``. diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst index eaae612..13993b8 100644 --- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst +++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst @@ -260,7 +260,7 @@ This section describes topics that are specific to the Microsoft Windows platforms. -.. only:: PRO or GPL +.. only:: PRO .. rubric:: Installing from the Command Line @@ -273,32 +273,15 @@ platforms. line you should pass parameter :switch:`/S` (and, optionally, :switch:`/D=<directory>`) as command-line arguments. -.. only:: PRO - - For example, for an unattended installation of - GNAT 7.0.2 into the default directory - ``C:\\GNATPRO\\7.0.2`` you would run: - - :: - - gnatpro-7.0.2-i686-pc-mingw32-bin.exe /S - - To install into a custom directory, say, ``C:\\TOOLS\\GNATPRO\\7.0.2``: - - :: - - gnatpro-7.0.2-i686-pc-mingw32-bin /S /D=C:\TOOLS\GNATPRO\7.0.2 - -.. only:: GPL - For example, for an unattended installation of - GNAT 2012 into ``C:\\GNAT\\2012``: + GNAT 19.2 into the default directory :file:`C:\\GNATPRO\\19.2` you + would run:: - :: + gnatpro-19.2-x86-windows-bin /S - gnat-gpl-2012-i686-pc-mingw32-bin /S /D=C:\GNAT\2012 + To install into a custom directory, say, :file:`C:\\TOOLS\\GNATPRO\\19.2`:: -.. only:: PRO or GPL + gnatpro-19.2-x86-windows-bin /S /D=C:\TOOLS\GNATPRO\19.2 You can use the same syntax for all installers. @@ -306,7 +289,6 @@ platforms. associations, so such activities need to be done by hand. - .. _Using_GNAT_on_Windows: Using GNAT on Windows @@ -488,6 +470,49 @@ and:: Ada.Command_Line.Argument (1) -> "'*.txt'" +Windows Socket Timeouts +----------------------- + +Microsoft Windows desktops older than ``8.0`` and Microsoft Windows Servers +older than ``2019`` set a socket timeout 500 milliseconds longer than the value +set by setsockopt with ``SO_RCVTIMEO`` and ``SO_SNDTIMEO`` options. The GNAT +runtime makes a correction for the difference in the corresponding Windows +versions. For Windows Server starting with version ``2019``, the user must +provide a manifest file for the GNAT runtime to be able to recognize that +the Windows version does not need the timeout correction. The manifest file +should be located in the same directory as the executable file, and its file +name must match the executable name suffixed by ``.manifest``. For example, +if the executable name is :file:`sock_wto.exe`, then the manifest file name +has to be :file:`sock_wto.exe.manifest`. The manifest file must contain at +least the following data:: + + <?xml version="1.0" encoding="UTF-8" standalone="yes"?> + <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> + <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1"> + <application> + <!-- Windows Vista --> + <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}"/> + <!-- Windows 7 --> + <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}"/> + <!-- Windows 8 --> + <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}"/> + <!-- Windows 8.1 --> + <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}"/> + <!-- Windows 10 --> + <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}"/> + </application> + </compatibility> + </assembly> + +Without the manifest file, the socket timeout is going to be overcorrected on +these Windows Server versions and the actual time is going to be 500 +milliseconds shorter than what was set with GNAT.Sockets.Set_Socket_Option. +Note that on Microsoft Windows versions where correction is necessary, there +is no way to set a socket timeout shorter than 500 ms. If a socket timeout +shorter than 500 ms is needed on these Windows versions, a call to +Check_Selector should be added before any socket read or write operations. + + .. _Mixed-Language_Programming_on_Windows: Mixed-Language Programming on Windows 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 48fedfe..d7388bb 100644 --- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst +++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst @@ -4531,8 +4531,9 @@ Some of the known limitations include: * identifiers with identical name (except casing) will generate compilation errors (e.g. ``shm_get`` vs ``SHM_GET``). -The code generated is using the Ada 2005 syntax, which makes it -easier to interface with other languages than previous versions of Ada. +The code is generated using Ada 2012 syntax, which makes it easier to interface +with other languages. In most cases you can still use the generated binding +even if your code is compiled using earlier versions of Ada (e.g. ``-gnat95``). .. _Running_the_binding_generator: @@ -4547,7 +4548,7 @@ header files needed by these files transitively. For example: .. code-block:: sh $ g++ -c -fdump-ada-spec -C /usr/include/time.h - $ gcc -c -gnat05 *.ads + $ 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 diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index b9a9a8d..8ff9ec6 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -421,7 +421,6 @@ package body Einfo is -- Never_Set_In_Source Flag115 -- Is_Visible_Lib_Unit Flag116 -- Is_Unchecked_Union Flag117 - -- Is_For_Access_Subtype Flag118 -- Has_Convention_Pragma Flag119 -- Has_Primitive_Operations Flag120 @@ -2303,12 +2302,6 @@ package body Einfo is return Flag70 (Id); end Is_First_Subtype; - function Is_For_Access_Subtype (Id : E) return B is - begin - pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); - return Flag118 (Id); - end Is_For_Access_Subtype; - function Is_Formal_Subprogram (Id : E) return B is begin return Flag111 (Id); @@ -5526,12 +5519,6 @@ package body Einfo is Set_Flag70 (Id, V); end Set_Is_First_Subtype; - procedure Set_Is_For_Access_Subtype (Id : E; V : B := True) is - begin - pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); - Set_Flag118 (Id, V); - end Set_Is_For_Access_Subtype; - procedure Set_Is_Formal_Subprogram (Id : E; V : B := True) is begin Set_Flag111 (Id, V); @@ -8127,7 +8114,7 @@ package body Einfo is function Is_Elaboration_Target (Id : Entity_Id) return Boolean is begin return - Ekind_In (Id, E_Constant, E_Variable) + Ekind_In (Id, E_Constant, E_Package, E_Variable) or else Is_Entry (Id) or else Is_Generic_Unit (Id) or else Is_Subprogram (Id) @@ -9826,7 +9813,6 @@ package body Einfo is W ("Is_Exported", Flag99 (Id)); W ("Is_Finalized_Transient", Flag252 (Id)); W ("Is_First_Subtype", Flag70 (Id)); - W ("Is_For_Access_Subtype", Flag118 (Id)); W ("Is_Formal_Subprogram", Flag111 (Id)); W ("Is_Frozen", Flag4 (Id)); W ("Is_Generic_Actual_Subprogram", Flag274 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 9dc6cc2..78208a1 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -320,7 +320,7 @@ package Einfo is -- an attempt to set the attribute on a subtype will raise an assert error. -- Other attributes are noted as applying to the [implementation base type --- only]. These are representation attributes which must always apply to a +-- only]. These are representation attributes which must always apply to a -- full non-private type, and where the attributes are always on the full -- type. The attribute can be referenced on a subtype (and automatically -- retrieves the value from the implementation base type). However, it is an @@ -2608,12 +2608,6 @@ package Einfo is -- Is_Formal_Subprogram (Flag111) -- Defined in all entities. Set for generic formal subprograms. --- Is_For_Access_Subtype (Flag118) --- Defined in E_Private_Subtype and E_Record_Subtype entities. Means the --- sole purpose of the type is to be designated by an Access_Subtype and --- hence should not be expanded into components because the type may not --- have been found or frozen yet. - -- Is_Frozen (Flag4) -- Defined in all type and subtype entities. Set if type or subtype has -- been frozen. @@ -4133,7 +4127,7 @@ package Einfo is -- Defined in generic subprograms, generic packages, and their -- instances. Also defined in the instances of the corresponding -- bodies. Denotes the renaming map (generic entities => instance --- entities) used to construct the instance by givin an index into +-- entities) used to construct the instance by giving an index into -- the tables used to represent these maps. See Sem_Ch12 for further -- details. The maps for package instances are also used when the -- instance is the actual corresponding to a formal package. @@ -4490,7 +4484,7 @@ package Einfo is -- Suppress_Initialization (Flag105) -- Defined in all variable, type and subtype entities. If set for a base -- type, then the generation of initialization procedures is suppressed --- for the type. Any other implicit initialiation (e.g. from the use of +-- for the type. Any other implicit initialization (e.g. from the use of -- pragma Initialize_Scalars) is also suppressed if this flag is set for -- either the subtype in question, or for the base type. For variables, -- this flag suppresses all implicit initialization for the object, even @@ -6458,7 +6452,6 @@ package Einfo is -- Stored_Constraint (Elist23) -- Has_Completion (Flag26) -- Is_Controlled_Active (Flag42) (base type only) - -- Is_For_Access_Subtype (Flag118) (subtype only) -- (plus type attributes) -- E_Procedure @@ -7311,7 +7304,6 @@ package Einfo is function Is_Exported (Id : E) return B; function Is_Finalized_Transient (Id : E) return B; function Is_First_Subtype (Id : E) return B; - function Is_For_Access_Subtype (Id : E) return B; function Is_Frozen (Id : E) return B; function Is_Generic_Instance (Id : E) return B; function Is_Hidden (Id : E) return B; @@ -8012,7 +8004,6 @@ package Einfo is procedure Set_Is_Exported (Id : E; V : B := True); procedure Set_Is_Finalized_Transient (Id : E; V : B := True); procedure Set_Is_First_Subtype (Id : E; V : B := True); - procedure Set_Is_For_Access_Subtype (Id : E; V : B := True); procedure Set_Is_Formal_Subprogram (Id : E; V : B := True); procedure Set_Is_Frozen (Id : E; V : B := True); procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True); @@ -8859,7 +8850,6 @@ package Einfo is pragma Inline (Is_First_Subtype); pragma Inline (Is_Fixed_Point_Type); pragma Inline (Is_Floating_Point_Type); - pragma Inline (Is_For_Access_Subtype); pragma Inline (Is_Formal); pragma Inline (Is_Formal_Object); pragma Inline (Is_Formal_Subprogram); @@ -9376,7 +9366,6 @@ package Einfo is pragma Inline (Set_Is_Exported); pragma Inline (Set_Is_Finalized_Transient); pragma Inline (Set_Is_First_Subtype); - pragma Inline (Set_Is_For_Access_Subtype); pragma Inline (Set_Is_Formal_Subprogram); pragma Inline (Set_Is_Frozen); pragma Inline (Set_Is_Generic_Actual_Subprogram); diff --git a/gcc/ada/env.c b/gcc/ada/env.c index cf839f5..698b177 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -30,15 +30,11 @@ ****************************************************************************/ #ifdef IN_RTS -# include "tconfig.h" -# include "tsystem.h" +# include "runtime.h" +# include <stdio.h> +# include <stdlib.h> +# include <string.h> -# include <sys/stat.h> -# include <fcntl.h> -# include <time.h> -# ifdef VMS -# include <unixio.h> -# endif /* We don't have libiberty, so use malloc. */ # define xmalloc(S) malloc (S) #else /* IN_RTS */ @@ -60,6 +56,9 @@ #endif #if defined (__vxworks) + #include <vxWorks.h> + #include <version.h> + #if defined (__RTP__) /* On VxWorks 6 Real-Time process mode, environ is defined in unistd.h. */ #include <unistd.h> @@ -69,14 +68,18 @@ envLib.h on VxWorks MILS and VxWorks 653. */ #include <vThreadsData.h> #include <envLib.h> - #else - /* This should work for kernel mode on both VxWorks 5 and VxWorks 6. */ + #elif (_WRS_VXWORKS_MAJOR <= 6) #include <envLib.h> - - /* In that mode environ is a macro which reference the following symbol. - As the symbol is not defined in any VxWorks include files we declare - it as extern. */ + /* In that mode the following symbol is not defined in any VxWorks + include files, prior to vxWorks 7, so we declare it as extern. */ extern char** ppGlobalEnviron; + #elif (_WRS_VXWORKS_MAJOR >= 7) + /* This should work for kernel mode on VxWorks 7.x. In 7.2 the tcb + is made private, so accessor functions must be used, in 7.0 it + is optional but there is no way to distinguish between 7.2 + and 7.0 since the version.h header file was never updated. */ + #include <envLib.h> + #include <taskLibCommon.h> #endif #endif @@ -102,89 +105,10 @@ __gnat_getenv (char *name, int *len, char **value) return; } -/* VMS specific declarations for set_env_value. */ - -#ifdef VMS - -typedef struct _ile3 -{ - unsigned short len, code; - __char_ptr32 adr; - __char_ptr32 retlen_adr; -} ile_s; - -#endif - void __gnat_setenv (char *name, char *value) { -#if defined (VMS) - struct dsc$descriptor_s name_desc; - $DESCRIPTOR (table_desc, "LNM$PROCESS"); - char *host_pathspec = value; - char *copy_pathspec; - int num_dirs_in_pathspec = 1; - char *ptr; - long status; - - name_desc.dsc$w_length = strlen (name); - name_desc.dsc$b_dtype = DSC$K_DTYPE_T; - name_desc.dsc$b_class = DSC$K_CLASS_S; - name_desc.dsc$a_pointer = name; /* ??? Danger, not 64bit safe. */ - - if (*host_pathspec == 0) - /* deassign */ - { - status = LIB$DELETE_LOGICAL (&name_desc, &table_desc); - /* no need to check status; if the logical name is not - defined, that's fine. */ - return; - } - - ptr = host_pathspec; - while (*ptr++) - if (*ptr == ',') - num_dirs_in_pathspec++; - - { - int i, status; - /* Alloca is guaranteed to be 32bit. */ - ile_s *ile_array = alloca (sizeof (ile_s) * (num_dirs_in_pathspec + 1)); - char *copy_pathspec = alloca (strlen (host_pathspec) + 1); - char *curr, *next; - - strcpy (copy_pathspec, host_pathspec); - curr = copy_pathspec; - for (i = 0; i < num_dirs_in_pathspec; i++) - { - next = strchr (curr, ','); - if (next == 0) - next = strchr (curr, 0); - - *next = 0; - ile_array[i].len = strlen (curr); - - /* Code 2 from lnmdef.h means it's a string. */ - ile_array[i].code = 2; - ile_array[i].adr = curr; - - /* retlen_adr is ignored. */ - ile_array[i].retlen_adr = 0; - curr = next + 1; - } - - /* Terminating item must be zero. */ - ile_array[i].len = 0; - ile_array[i].code = 0; - ile_array[i].adr = 0; - ile_array[i].retlen_adr = 0; - - status = LIB$SET_LOGICAL (&name_desc, 0, &table_desc, 0, ile_array); - if ((status & 1) != 1) - LIB$SIGNAL (status); - } - -#elif (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__) +#if (defined (__vxworks) && defined (__RTP__)) || defined (__APPLE__) setenv (name, value, 1); #else @@ -206,10 +130,7 @@ __gnat_setenv (char *name, char *value) char ** __gnat_environ (void) { -#if defined (VMS) || defined (RTX) - /* Not implemented */ - return NULL; -#elif defined (__MINGW32__) +#if defined (__MINGW32__) return _environ; #elif defined (__sun__) extern char **_environ; @@ -223,16 +144,24 @@ __gnat_environ (void) extern char **environ; return environ; #else - return environ; + #if defined (__RTP__) || defined (VTHREADS) || (_WRS_VXWORKS_MAJOR <= 6) + return environ; + #elif (_WRS_VXWORKS_MAJOR >= 7) + char **task_environ; + + task_environ = envGet (taskIdSelf ()); + + if (task_environ == NULL) + return ppGlobalEnviron; + else + return task_environ; + #endif #endif } void __gnat_unsetenv (char *name) { -#if defined (VMS) - /* Not implemented */ - return; -#elif defined (__hpux__) || defined (__sun__) \ +#if defined (__hpux__) || defined (__sun__) \ || (defined (__vxworks) && ! defined (__RTP__)) \ || defined (_AIX) || defined (__Lynx__) @@ -288,10 +217,7 @@ void __gnat_unsetenv (char *name) void __gnat_clearenv (void) { -#if defined (VMS) - /* not implemented */ - return; -#elif defined (__sun__) \ +#if defined (__sun__) \ || (defined (__vxworks) && ! defined (__RTP__)) || defined (__Lynx__) \ || defined (__PikeOS__) /* On Solaris, VxWorks (not RTPs), and Lynx there is no system diff --git a/gcc/ada/errno.c b/gcc/ada/errno.c index a64ae87..18f14ea 100644 --- a/gcc/ada/errno.c +++ b/gcc/ada/errno.c @@ -35,21 +35,10 @@ as it may be defined using a macro. */ - +#ifndef _REENTRANT #define _REENTRANT -#define _THREAD_SAFE - -#ifdef MaRTE - -/* MaRTE OS provides its own implementation of errno related functionality. We - want to ensure the use of the MaRTE version for tasking programs (the MaRTE - library will not be linked if no tasking constructs are used), so we use the - weak symbols mechanism to use the MaRTE version whenever is available. */ - -#pragma weak __get_errno -#pragma weak __set_errno - #endif +#define _THREAD_SAFE #include <errno.h> int diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 0c8ef5d..81e2910 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -53,7 +53,7 @@ package body Erroutc is function Matches (S : String; P : String) return Boolean; -- Returns true if the String S patches the pattern P, which can contain - -- wild card chars (*). The entire pattern must match the entire string. + -- wildcard chars (*). The entire pattern must match the entire string. -- Case is ignored in the comparison (so X matches x). function Sloc_In_Range (Loc, Start, Stop : Source_Ptr) return Boolean; @@ -1606,6 +1606,7 @@ package body Erroutc is if Start <= Cur_Loc and then Cur_Loc <= Stop then return True; end if; + Cur_Loc := Instantiation_Location (Cur_Loc); end loop; diff --git a/gcc/ada/exit.c b/gcc/ada/exit.c index 3ac3596..3f6ef21 100644 --- a/gcc/ada/exit.c +++ b/gcc/ada/exit.c @@ -29,21 +29,6 @@ * * ****************************************************************************/ -#ifdef __alpha_vxworks -#include "vxWorks.h" -#endif - -#ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" -#include <sys/stat.h> -#else -#include "config.h" -#include "system.h" -#endif - -#include "adaint.h" - #ifdef __cplusplus extern "C" { #endif diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index b5bd222..c944db6 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -192,7 +192,7 @@ package body Exp_Aggr is procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id); -- Transform a record aggregate into a sequence of assignments performed - -- component by component. N is an N_Aggregate or N_Extension_Aggregate. + -- component by component. N is an N_Aggregate or N_Extension_Aggregate. -- Typ is the type of the record aggregate. procedure Expand_Record_Aggregate @@ -217,6 +217,11 @@ package body Exp_Aggr is -- defaults. An aggregate for a type with mutable components must be -- expanded into individual assignments. + function In_Place_Assign_OK (N : Node_Id) return Boolean; + -- Predicate to determine whether an aggregate assignment can be done in + -- place, because none of the new values can depend on the components of + -- the target of the assignment. + procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); -- If the type of the aggregate is a type extension with renamed discrimi- -- nants, we must initialize the hidden discriminants of the parent. @@ -646,24 +651,8 @@ package body Exp_Aggr is -- Checks 11: The C code generator cannot handle aggregates that are -- not part of an object declaration. - if Modify_Tree_For_C then - declare - Par : Node_Id := Parent (N); - - begin - -- Skip enclosing nested aggregates and their qualified - -- expressions. - - while Nkind (Par) = N_Aggregate - or else Nkind (Par) = N_Qualified_Expression - loop - Par := Parent (Par); - end loop; - - if Nkind (Par) /= N_Object_Declaration then - return False; - end if; - end; + if Modify_Tree_For_C and then not Is_CCG_Supported_Aggregate (N) then + return False; end if; -- Checks on components @@ -1354,11 +1343,11 @@ package body Exp_Aggr is -- transient scope, which leads to premature finalization. -- This in-place expansion is not performed for limited transient - -- objects because the initialization is already done in-place. + -- objects, because the initialization is already done in place. if In_Place_Expansion then - -- Suppress the removal of side effects by general analysis + -- Suppress the removal of side effects by general analysis, -- because this behavior is emulated here. This avoids the -- generation of a transient scope, which leads to out-of-order -- adjustment and finalization. @@ -4134,6 +4123,252 @@ package body Exp_Aggr is Insert_Actions_After (Decl, Aggr_Code); end Convert_Array_Aggr_In_Allocator; + ------------------------ + -- In_Place_Assign_OK -- + ------------------------ + + function In_Place_Assign_OK (N : Node_Id) return Boolean is + Is_Array : constant Boolean := Is_Array_Type (Etype (N)); + + Aggr_In : Node_Id; + Aggr_Lo : Node_Id; + Aggr_Hi : Node_Id; + Obj_In : Node_Id; + Obj_Lo : Node_Id; + Obj_Hi : Node_Id; + + function Safe_Aggregate (Aggr : Node_Id) return Boolean; + -- Check recursively that each component of a (sub)aggregate does not + -- depend on the variable being assigned to. + + function Safe_Component (Expr : Node_Id) return Boolean; + -- Verify that an expression cannot depend on the variable being + -- assigned to. Room for improvement here (but less than before). + + -------------------- + -- Safe_Aggregate -- + -------------------- + + function Safe_Aggregate (Aggr : Node_Id) return Boolean is + Expr : Node_Id; + + begin + if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then + return False; + end if; + + if Present (Expressions (Aggr)) then + Expr := First (Expressions (Aggr)); + while Present (Expr) loop + if Nkind (Expr) = N_Aggregate then + if not Safe_Aggregate (Expr) then + return False; + end if; + + elsif not Safe_Component (Expr) then + return False; + end if; + + Next (Expr); + end loop; + end if; + + if Present (Component_Associations (Aggr)) then + Expr := First (Component_Associations (Aggr)); + while Present (Expr) loop + if Nkind (Expression (Expr)) = N_Aggregate then + if not Safe_Aggregate (Expression (Expr)) then + return False; + end if; + + -- If association has a box, no way to determine yet whether + -- default can be assigned in place. + + elsif Box_Present (Expr) then + return False; + + elsif not Safe_Component (Expression (Expr)) then + return False; + end if; + + Next (Expr); + end loop; + end if; + + return True; + end Safe_Aggregate; + + -------------------- + -- Safe_Component -- + -------------------- + + function Safe_Component (Expr : Node_Id) return Boolean is + Comp : Node_Id := Expr; + + function Check_Component (Comp : Node_Id) return Boolean; + -- Do the recursive traversal, after copy + + --------------------- + -- Check_Component -- + --------------------- + + function Check_Component (Comp : Node_Id) return Boolean is + begin + if Is_Overloaded (Comp) then + return False; + end if; + + return Compile_Time_Known_Value (Comp) + + or else (Is_Entity_Name (Comp) + and then Present (Entity (Comp)) + and then Ekind (Entity (Comp)) not in Type_Kind + and then No (Renamed_Object (Entity (Comp)))) + + or else (Nkind (Comp) = N_Attribute_Reference + and then Check_Component (Prefix (Comp))) + + or else (Nkind (Comp) in N_Binary_Op + and then Check_Component (Left_Opnd (Comp)) + and then Check_Component (Right_Opnd (Comp))) + + or else (Nkind (Comp) in N_Unary_Op + and then Check_Component (Right_Opnd (Comp))) + + or else (Nkind (Comp) = N_Selected_Component + and then Is_Array + and then Check_Component (Prefix (Comp))) + + or else (Nkind_In (Comp, N_Type_Conversion, + N_Unchecked_Type_Conversion) + and then Check_Component (Expression (Comp))); + end Check_Component; + + -- Start of processing for Safe_Component + + begin + -- If the component appears in an association that may correspond + -- to more than one element, it is not analyzed before expansion + -- into assignments, to avoid side effects. We analyze, but do not + -- resolve the copy, to obtain sufficient entity information for + -- the checks that follow. If component is overloaded we assume + -- an unsafe function call. + + if not Analyzed (Comp) then + if Is_Overloaded (Expr) then + return False; + + elsif Nkind (Expr) = N_Aggregate + and then not Is_Others_Aggregate (Expr) + then + return False; + + elsif Nkind (Expr) = N_Allocator then + + -- For now, too complex to analyze + + return False; + + elsif Nkind (Parent (Expr)) = N_Iterated_Component_Association then + + -- Ditto for iterated component associations, which in general + -- require an enclosing loop and involve nonstatic expressions. + + return False; + end if; + + Comp := New_Copy_Tree (Expr); + Set_Parent (Comp, Parent (Expr)); + Analyze (Comp); + end if; + + if Nkind (Comp) = N_Aggregate then + return Safe_Aggregate (Comp); + else + return Check_Component (Comp); + end if; + end Safe_Component; + + -- Start of processing for In_Place_Assign_OK + + begin + -- By-copy semantic cannot be guaranteed for controlled objects or + -- objects with discriminants. + + if Needs_Finalization (Etype (N)) + or else Has_Discriminants (Etype (N)) + then + return False; + + elsif Is_Array and then Present (Component_Associations (N)) then + + -- On assignment, sliding can take place, so we cannot do the + -- assignment in place unless the bounds of the aggregate are + -- statically equal to those of the target. + + -- If the aggregate is given by an others choice, the bounds are + -- derived from the left-hand side, and the assignment is safe if + -- the expression is. + + if Is_Others_Aggregate (N) then + return + Safe_Component + (Expression (First (Component_Associations (N)))); + end if; + + Aggr_In := First_Index (Etype (N)); + + if Nkind (Parent (N)) = N_Assignment_Statement then + Obj_In := First_Index (Etype (Name (Parent (N)))); + + else + -- Context is an allocator. Check bounds of aggregate against + -- given type in qualified expression. + + pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator); + Obj_In := First_Index (Etype (Entity (Subtype_Mark (Parent (N))))); + end if; + + while Present (Aggr_In) loop + Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi); + Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi); + + if not Compile_Time_Known_Value (Aggr_Lo) + or else not Compile_Time_Known_Value (Obj_Lo) + or else not Compile_Time_Known_Value (Obj_Hi) + or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo) + then + return False; + + -- For an assignment statement we require static matching of + -- bounds. Ditto for an allocator whose qualified expression + -- is a constrained type. If the expression in the allocator + -- is an unconstrained array, we accept an upper bound that + -- is not static, to allow for nonstatic expressions of the + -- base type. Clearly there are further possibilities (with + -- diminishing returns) for safely building arrays in place + -- here. + + elsif Nkind (Parent (N)) = N_Assignment_Statement + or else Is_Constrained (Etype (Parent (N))) + then + if not Compile_Time_Known_Value (Aggr_Hi) + or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) + then + return False; + end if; + end if; + + Next_Index (Aggr_In); + Next_Index (Obj_In); + end loop; + end if; + + -- Now check the component values themselves + + return Safe_Aggregate (N); + end In_Place_Assign_OK; + ---------------------------- -- Convert_To_Assignments -- ---------------------------- @@ -4232,10 +4467,11 @@ package body Exp_Aggr is Establish_Transient_Scope (N, Manage_Sec_Stack => False); end if; - -- If the aggregate is nonlimited, create a temporary. If it is limited - -- and context is an assignment, this is a subaggregate for an enclosing - -- aggregate being expanded. It must be built in place, so use target of - -- the current assignment. + -- If the aggregate is nonlimited, create a temporary, since aggregates + -- have "by copy" semantics. If it is limited and context is an + -- assignment, this is a subaggregate for an enclosing aggregate being + -- expanded. It must be built in place, so use target of the current + -- assignment. if Is_Limited_Type (Typ) and then Nkind (Parent (N)) = N_Assignment_Statement @@ -4245,16 +4481,14 @@ package body Exp_Aggr is Build_Record_Aggr_Code (N, Typ, Target_Expr)); Rewrite (Parent (N), Make_Null_Statement (Loc)); - -- Generating C, do not declare a temporary to initialize an aggregate - -- assigned to Out or In_Out parameters whose type has no discriminants. - -- This avoids stack overflow errors at run time. + -- Do not declare a temporary to initialize an aggregate assigned to an + -- identifier when in-place assignment is possible, preserving the + -- by-copy semantic of aggregates. This avoids large stack usage and + -- generates more efficient code. - elsif Modify_Tree_For_C - and then Nkind (Parent (N)) = N_Assignment_Statement + elsif Nkind (Parent (N)) = N_Assignment_Statement and then Nkind (Name (Parent (N))) = N_Identifier - and then Ekind_In (Entity (Name (Parent (N))), E_Out_Parameter, - E_In_Out_Parameter) - and then not Has_Discriminants (Etype (Entity (Name (Parent (N))))) + and then In_Place_Assign_OK (N) then Target_Expr := New_Copy_Tree (Name (Parent (N))); Insert_Actions (Parent (N), @@ -4886,7 +5120,7 @@ package body Exp_Aggr is -- case pass it as is to Gigi. Note that a necessary condition for -- static processing is that the aggregate be fully positional. - -- 5. If in place aggregate expansion is possible (i.e. no need to create + -- 5. If in-place aggregate expansion is possible (i.e. no need to create -- a temporary) then mark the aggregate as such and return. Otherwise -- create a new temporary and generate the appropriate initialization -- code. @@ -4910,7 +5144,7 @@ package body Exp_Aggr is -- The type of each index In_Place_Assign_OK_For_Declaration : Boolean := False; - -- True if we are to generate an in place assignment for a declaration + -- True if we are to generate an in-place assignment for a declaration Maybe_In_Place_OK : Boolean; -- If the type is neither controlled nor packed and the aggregate @@ -4945,11 +5179,6 @@ package body Exp_Aggr is -- subaggregate we start the computation from. Dim is the dimension -- corresponding to the subaggregate. - function In_Place_Assign_OK return Boolean; - -- Simple predicate to determine whether an aggregate assignment can - -- be done in place, because none of the new values can depend on the - -- components of the target of the assignment. - procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos); -- Checks that if an others choice is present in any subaggregate, no -- aggregate index is outside the bounds of the index constraint. @@ -5437,242 +5666,6 @@ package body Exp_Aggr is end if; end Compute_Others_Present; - ------------------------ - -- In_Place_Assign_OK -- - ------------------------ - - function In_Place_Assign_OK return Boolean is - Aggr_In : Node_Id; - Aggr_Lo : Node_Id; - Aggr_Hi : Node_Id; - Obj_In : Node_Id; - Obj_Lo : Node_Id; - Obj_Hi : Node_Id; - - function Safe_Aggregate (Aggr : Node_Id) return Boolean; - -- Check recursively that each component of a (sub)aggregate does not - -- depend on the variable being assigned to. - - function Safe_Component (Expr : Node_Id) return Boolean; - -- Verify that an expression cannot depend on the variable being - -- assigned to. Room for improvement here (but less than before). - - -------------------- - -- Safe_Aggregate -- - -------------------- - - function Safe_Aggregate (Aggr : Node_Id) return Boolean is - Expr : Node_Id; - - begin - if Nkind (Parent (Aggr)) = N_Iterated_Component_Association then - return False; - end if; - - if Present (Expressions (Aggr)) then - Expr := First (Expressions (Aggr)); - while Present (Expr) loop - if Nkind (Expr) = N_Aggregate then - if not Safe_Aggregate (Expr) then - return False; - end if; - - elsif not Safe_Component (Expr) then - return False; - end if; - - Next (Expr); - end loop; - end if; - - if Present (Component_Associations (Aggr)) then - Expr := First (Component_Associations (Aggr)); - while Present (Expr) loop - if Nkind (Expression (Expr)) = N_Aggregate then - if not Safe_Aggregate (Expression (Expr)) then - return False; - end if; - - -- If association has a box, no way to determine yet - -- whether default can be assigned in place. - - elsif Box_Present (Expr) then - return False; - - elsif not Safe_Component (Expression (Expr)) then - return False; - end if; - - Next (Expr); - end loop; - end if; - - return True; - end Safe_Aggregate; - - -------------------- - -- Safe_Component -- - -------------------- - - function Safe_Component (Expr : Node_Id) return Boolean is - Comp : Node_Id := Expr; - - function Check_Component (Comp : Node_Id) return Boolean; - -- Do the recursive traversal, after copy - - --------------------- - -- Check_Component -- - --------------------- - - function Check_Component (Comp : Node_Id) return Boolean is - begin - if Is_Overloaded (Comp) then - return False; - end if; - - return Compile_Time_Known_Value (Comp) - - or else (Is_Entity_Name (Comp) - and then Present (Entity (Comp)) - and then No (Renamed_Object (Entity (Comp)))) - - or else (Nkind (Comp) = N_Attribute_Reference - and then Check_Component (Prefix (Comp))) - - or else (Nkind (Comp) in N_Binary_Op - and then Check_Component (Left_Opnd (Comp)) - and then Check_Component (Right_Opnd (Comp))) - - or else (Nkind (Comp) in N_Unary_Op - and then Check_Component (Right_Opnd (Comp))) - - or else (Nkind (Comp) = N_Selected_Component - and then Check_Component (Prefix (Comp))) - - or else (Nkind (Comp) = N_Unchecked_Type_Conversion - and then Check_Component (Expression (Comp))); - end Check_Component; - - -- Start of processing for Safe_Component - - begin - -- If the component appears in an association that may correspond - -- to more than one element, it is not analyzed before expansion - -- into assignments, to avoid side effects. We analyze, but do not - -- resolve the copy, to obtain sufficient entity information for - -- the checks that follow. If component is overloaded we assume - -- an unsafe function call. - - if not Analyzed (Comp) then - if Is_Overloaded (Expr) then - return False; - - elsif Nkind (Expr) = N_Aggregate - and then not Is_Others_Aggregate (Expr) - then - return False; - - elsif Nkind (Expr) = N_Allocator then - - -- For now, too complex to analyze - - return False; - - elsif Nkind (Parent (Expr)) = - N_Iterated_Component_Association - then - -- Ditto for iterated component associations, which in - -- general require an enclosing loop and involve nonstatic - -- expressions. - - return False; - end if; - - Comp := New_Copy_Tree (Expr); - Set_Parent (Comp, Parent (Expr)); - Analyze (Comp); - end if; - - if Nkind (Comp) = N_Aggregate then - return Safe_Aggregate (Comp); - else - return Check_Component (Comp); - end if; - end Safe_Component; - - -- Start of processing for In_Place_Assign_OK - - begin - if Present (Component_Associations (N)) then - - -- On assignment, sliding can take place, so we cannot do the - -- assignment in place unless the bounds of the aggregate are - -- statically equal to those of the target. - - -- If the aggregate is given by an others choice, the bounds are - -- derived from the left-hand side, and the assignment is safe if - -- the expression is. - - if Is_Others_Aggregate (N) then - return - Safe_Component - (Expression (First (Component_Associations (N)))); - end if; - - Aggr_In := First_Index (Etype (N)); - - if Nkind (Parent (N)) = N_Assignment_Statement then - Obj_In := First_Index (Etype (Name (Parent (N)))); - - else - -- Context is an allocator. Check bounds of aggregate against - -- given type in qualified expression. - - pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator); - Obj_In := - First_Index (Etype (Entity (Subtype_Mark (Parent (N))))); - end if; - - while Present (Aggr_In) loop - Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi); - Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi); - - if not Compile_Time_Known_Value (Aggr_Lo) - or else not Compile_Time_Known_Value (Obj_Lo) - or else not Compile_Time_Known_Value (Obj_Hi) - or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo) - then - return False; - - -- For an assignment statement we require static matching of - -- bounds. Ditto for an allocator whose qualified expression - -- is a constrained type. If the expression in the allocator - -- is an unconstrained array, we accept an upper bound that - -- is not static, to allow for nonstatic expressions of the - -- base type. Clearly there are further possibilities (with - -- diminishing returns) for safely building arrays in place - -- here. - - elsif Nkind (Parent (N)) = N_Assignment_Statement - or else Is_Constrained (Etype (Parent (N))) - then - if not Compile_Time_Known_Value (Aggr_Hi) - or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) - then - return False; - end if; - end if; - - Next_Index (Aggr_In); - Next_Index (Obj_In); - end loop; - end if; - - -- Now check the component values themselves - - return Safe_Aggregate (N); - end In_Place_Assign_OK; - ------------------ -- Others_Check -- ------------------ @@ -6219,7 +6212,7 @@ package body Exp_Aggr is -- STEP 4 - -- Look if in place aggregate expansion is possible + -- Check whether in-place aggregate expansion is possible -- For object declarations we build the aggregate in place, unless -- the array is bit-packed. @@ -6255,11 +6248,11 @@ package body Exp_Aggr is else Maybe_In_Place_OK := (Nkind (Parent (N)) = N_Assignment_Statement - and then In_Place_Assign_OK) + and then In_Place_Assign_OK (N)) or else (Nkind (Parent (Parent (N))) = N_Allocator - and then In_Place_Assign_OK); + and then In_Place_Assign_OK (N)); end if; -- If this is an array of tasks, it will be expanded into build-in-place @@ -6371,7 +6364,7 @@ package body Exp_Aggr is -- Step 5 - -- In place aggregate expansion is not possible + -- In-place aggregate expansion is not possible else Maybe_In_Place_OK := False; @@ -6423,11 +6416,11 @@ package body Exp_Aggr is Target := New_Copy (Tmp); end if; - -- If we are to generate an in place assignment for a declaration or + -- If we are to generate an in-place assignment for a declaration or -- an assignment statement, and the assignment can be done directly -- by the back end, then do not expand further. - -- ??? We can also do that if in place expansion is not possible but + -- ??? We can also do that if in-place expansion is not possible but -- then we could go into an infinite recursion. if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK) @@ -7685,30 +7678,31 @@ package body Exp_Aggr is function Is_CCG_Supported_Aggregate (N : Node_Id) return Boolean is - In_Obj_Decl : Boolean := False; - P : Node_Id := Parent (N); + P : Node_Id := Parent (N); begin - while Present (P) loop - if Nkind (P) = N_Object_Declaration then - In_Obj_Decl := True; - end if; + -- Aggregates are not supported for nonstandard rep clauses, since they + -- may lead to extra padding fields in CCG. + + if Ekind (Etype (N)) in Record_Kind + and then Has_Non_Standard_Rep (Etype (N)) + then + return False; + end if; + while Present (P) and then Nkind (P) = N_Aggregate loop P := Parent (P); end loop; -- Cases where aggregates are supported by the CCG backend - if In_Obj_Decl then - if Nkind (Parent (N)) = N_Object_Declaration then - return True; + if Nkind (P) = N_Object_Declaration then + return True; - elsif Nkind (Parent (N)) = N_Qualified_Expression - and then Nkind_In (Parent (Parent (N)), N_Allocator, - N_Object_Declaration) - then - return True; - end if; + elsif Nkind (P) = N_Qualified_Expression + and then Nkind_In (Parent (P), N_Allocator, N_Object_Declaration) + then + return True; end if; return False; @@ -8757,7 +8751,7 @@ package body Exp_Aggr is Val := 0; Packed_Num := 0; - -- Account for endianness. See corresponding comment in + -- Account for endianness. See corresponding comment in -- Packed_Array_Aggregate_Handled concerning the following. if Bytes_Big_Endian diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 1e1b2f9..9d6da33 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -39,6 +39,7 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; +with Expander; use Expander; with Freeze; use Freeze; with Gnatvsn; use Gnatvsn; with Itypes; use Itypes; @@ -1384,12 +1385,15 @@ package body Exp_Attr is Stmts : List_Id; begin + Func_Id := Make_Temporary (Loc, 'F'); + -- Wrap the condition of the while loop in a Boolean function. -- This avoids the duplication of the same code which may lead -- to gigi issues with respect to multiple declaration of the -- same entity in the presence of side effects or checks. Note - -- that the condition actions must also be relocated to the - -- wrapping function. + -- that the condition actions must also be relocated into the + -- wrapping function because they may contain itypes, e.g. in + -- the case of a comparison involving slices. -- Generate: -- <condition actions> @@ -1403,7 +1407,9 @@ package body Exp_Attr is Append_To (Stmts, Make_Simple_Return_Statement (Loc, - Expression => Relocate_Node (Condition (Scheme)))); + Expression => + New_Copy_Tree (Condition (Scheme), + New_Scope => Func_Id))); -- Generate: -- function Fnn return Boolean is @@ -1411,7 +1417,6 @@ package body Exp_Attr is -- <Stmts> -- end Fnn; - Func_Id := Make_Temporary (Loc, 'F'); Func_Decl := Make_Subprogram_Body (Loc, Specification => @@ -3279,6 +3284,13 @@ package body Exp_Attr is Expr := Unchecked_Convert_To (Ptyp, First (Exprs)); + -- Ensure that the expression is not truncated since the "bad" bits + -- are desired. + + if Nkind (Expr) = N_Unchecked_Type_Conversion then + Set_No_Truncation (Expr); + end if; + Insert_Action (N, Make_Raise_Constraint_Error (Loc, Condition => @@ -3529,7 +3541,7 @@ package body Exp_Attr is -- We transform -- fixtype'Fixed_Value (integer-value) - -- inttype'Fixed_Value (fixed-value) + -- inttype'Integer_Value (fixed-value) -- into @@ -3538,75 +3550,30 @@ package body Exp_Attr is -- respectively. - -- We do all the required analysis of the conversion here, because we do - -- not want this to go through the fixed-point conversion circuits. Note - -- that the back end always treats fixed-point as equivalent to the - -- corresponding integer type anyway. - -- However, in order to remove the handling of Do_Range_Check from the - -- backend, we force the generation of a check on the result by - -- setting the result type appropriately. Apply_Conversion_Checks - -- will generate the required expansion. + -- We set Conversion_OK on the conversion because we do not want it + -- to go through the fixed-point conversion circuits. when Attribute_Fixed_Value | Attribute_Integer_Value => - Rewrite (N, - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc), - Expression => Relocate_Node (First (Exprs)))); - - -- Indicate that the result of the conversion may require a - -- range check (see below); + Rewrite (N, OK_Convert_To (Entity (Pref), First (Exprs))); - Set_Etype (N, Base_Type (Entity (Pref))); - Set_Analyzed (N); - - -- Note: it might appear that a properly analyzed unchecked + -- Note that it might appear that a properly analyzed unchecked -- conversion would be just fine here, but that's not the case, - -- since the full range checks performed by the following code + -- since the full range checks performed by the following calls -- are critical. - -- Given that Fixed-point conversions are not further expanded - -- to prevent the involvement of real type operations we have to - -- construct two checks explicitly: one on the operand, and one - -- on the result. This used to be done in part in the back-end, - -- but for other targets (E.g. LLVM) it is preferable to create - -- the tests in full in the front-end. - - if Is_Fixed_Point_Type (Etype (N)) then - declare - Loc : constant Source_Ptr := Sloc (N); - Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Expr : constant Node_Id := Expression (N); - Fst : constant Entity_Id := Root_Type (Etype (N)); - Decl : Node_Id; - - begin - Decl := - Make_Full_Type_Declaration (Sloc (N), - Defining_Identifier => Equiv_T, - Type_Definition => - Make_Signed_Integer_Type_Definition (Loc, - Low_Bound => - Make_Integer_Literal (Loc, - Intval => - Corresponding_Integer_Value - (Type_Low_Bound (Fst))), - High_Bound => - Make_Integer_Literal (Loc, - Intval => - Corresponding_Integer_Value - (Type_High_Bound (Fst))))); - Insert_Action (N, Decl); - -- Verify that the conversion is possible + Apply_Type_Conversion_Checks (N); - Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed); + -- Note that Apply_Type_Conversion_Checks only deals with the + -- overflow checks on conversions involving fixed-point types + -- so we must apply range checks manually on them and expand. - -- and verify that the result is in range + Apply_Scalar_Range_Check + (Expression (N), Etype (N), Fixed_Int => True); - Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed); - end; - end if; + Set_Analyzed (N); + Expand (N); ----------- -- Floor -- @@ -3997,11 +3964,14 @@ package body Exp_Attr is declare Rtyp : constant Entity_Id := Root_Type (P_Type); - Expr : Node_Id; + + Expr : Node_Id; -- call to Descendant_Tag + Get_Tag : Node_Id; -- expression to read the 'Tag begin -- Read the internal tag (RM 13.13.2(34)) and use it to - -- initialize a dummy tag value. We used to generate: + -- initialize a dummy tag value. We used to unconditionally + -- generate: -- -- Descendant_Tag (String'Input (Strm), P_Type); -- @@ -4012,6 +3982,11 @@ package body Exp_Attr is -- String_Input_Blk_IO, except that if the String is -- absurdly long, it raises an exception. -- + -- However, if the No_Stream_Optimizations restriction + -- is active, we disable this unnecessary attempt at + -- robustness; we really need to read the string + -- character-by-character. + -- -- This value is used only to provide a controlling -- argument for the eventual _Input call. Descendant_Tag is -- called rather than Internal_Tag to ensure that we have a @@ -4026,18 +4001,30 @@ package body Exp_Attr is -- this constant in Cntrl, but this caused a secondary stack -- leak. + if Restriction_Active (No_Stream_Optimizations) then + Get_Tag := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))); + else + Get_Tag := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_String_Input_Tag), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))); + end if; + Expr := Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), Parameter_Associations => New_List ( - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_String_Input_Tag), Loc), - Parameter_Associations => New_List ( - Relocate_Node (Duplicate_Subexpr (Strm)))), - + Get_Tag, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (P_Type, Loc), Attribute_Name => Name_Tag))); diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 7296e6f..29d8718 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1308,8 +1308,8 @@ package body Exp_Ch11 is Append_To (L, Make_Character_Literal (Loc, - Chars => Name_uA, - Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); + Chars => Name_uA, + Char_Literal_Value => UI_From_Int (Character'Pos ('A')))); -- Name_Length component: Nam'Length diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 6ee7f75..f3c2c01 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -232,7 +232,7 @@ package body Exp_Ch13 is Convert_To (RTE (RE_Size_Type), Expression (N))); -- If the clause is not generated by an aspect, insert - -- the assignment here. Freezing rules ensure that this + -- the assignment here. Freezing rules ensure that this -- is safe, or clause will have been rejected already. if Is_List_Member (N) then @@ -724,7 +724,7 @@ package body Exp_Ch13 is end if; -- If the record representation clause has no components, then - -- completely remove it. Note that we also have to remove + -- completely remove it. Note that we also have to remove -- ourself from the Rep Item list. if Is_Empty_List (Component_Clauses (N)) then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 753c5fb..834aaa3 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1555,23 +1555,19 @@ package body Exp_Ch3 is -- Handle the optionally generated formal *_skip_null_excluding_checks - if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) then - - -- Look at the associated node for the object we are referencing - -- and verify that we are expanding a call to an Init_Proc for an - -- internally generated object declaration before passing True and - -- skipping the relevant checks. - - if Nkind (Id_Ref) in N_Has_Entity - and then Comes_From_Source (Associated_Node (Id_Ref)) - then - Append_To (Args, New_Occurrence_Of (Standard_True, Loc)); - - -- Otherwise, we pass False to perform null-excluding checks - - else - Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); - end if; + -- Look at the associated node for the object we are referencing and + -- verify that we are expanding a call to an Init_Proc for an internally + -- generated object declaration before passing True and skipping the + -- relevant checks. + + if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) + and then Nkind (Id_Ref) in N_Has_Entity + and then (Comes_From_Source (Id_Ref) + or else (Present (Associated_Node (Id_Ref)) + and then Comes_From_Source + (Associated_Node (Id_Ref)))) + then + Append_To (Args, New_Occurrence_Of (Standard_True, Loc)); end if; -- Add discriminant values if discriminants are present @@ -4852,7 +4848,7 @@ package body Exp_Ch3 is Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), Low_Bound => Make_Integer_Literal (Loc, - Intval => Enumeration_Rep (Ent)), + Intval => Enumeration_Rep (Ent)), High_Bound => Make_Integer_Literal (Loc, Intval => Last_Repval))), @@ -8695,6 +8691,7 @@ package body Exp_Ch3 is Make_Defining_Identifier (Loc, New_External_Name (Chars (Component_Type (Typ)), "_skip_null_excluding_check")), + Expression => New_Occurrence_Of (Standard_False, Loc), In_Present => True, Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc))); @@ -9480,14 +9477,22 @@ package body Exp_Ch3 is -- or a null statement if the list L is empty + -- Equality may be user-defined for a given component type, in which case + -- a function call is constructed instead of an operator node. This is an + -- Ada 2012 change in the composability of equality for untagged composite + -- types. + function Make_Eq_If (E : Entity_Id; L : List_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (E); + Loc : constant Source_Ptr := Sloc (E); + C : Node_Id; - Field_Name : Name_Id; Cond : Node_Id; + Field_Name : Name_Id; + Next_Test : Node_Id; + Typ : Entity_Id; begin if No (L) then @@ -9498,6 +9503,7 @@ package body Exp_Ch3 is C := First_Non_Pragma (L); while Present (C) loop + Typ := Etype (Defining_Identifier (C)); Field_Name := Chars (Defining_Identifier (C)); -- The tags must not be compared: they are not part of the value. @@ -9510,22 +9516,55 @@ package body Exp_Ch3 is -- discriminants could be picked up in the private type case. if Field_Name = Name_uParent - and then Is_Interface (Etype (Defining_Identifier (C))) + and then Is_Interface (Typ) then null; elsif Field_Name /= Name_uTag then - Evolve_Or_Else (Cond, - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_X), - Selector_Name => Make_Identifier (Loc, Field_Name)), + declare + Lhs : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => Make_Identifier (Loc, Field_Name)); - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => Make_Identifier (Loc, Name_Y), - Selector_Name => Make_Identifier (Loc, Field_Name)))); + Rhs : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_Y), + Selector_Name => Make_Identifier (Loc, Field_Name)); + Eq_Call : Node_Id; + + begin + -- Build equality code with a user-defined operator, if + -- available, and with the predefined "=" otherwise. For + -- compatibility with older Ada versions, and preserve the + -- workings of some ASIS tools, we also use the predefined + -- operation if the component-type equality is abstract, + -- rather than raising Program_Error. + + if Ada_Version < Ada_2012 then + Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); + + else + Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs); + + if No (Eq_Call) then + Next_Test := Make_Op_Ne (Loc, Lhs, Rhs); + + -- If a component has a defined abstract equality, its + -- application raises Program_Error on that component + -- and therefore on the current variant. + + elsif Nkind (Eq_Call) = N_Raise_Program_Error then + Set_Etype (Eq_Call, Standard_Boolean); + Next_Test := Make_Op_Not (Loc, Eq_Call); + + else + Next_Test := Make_Op_Not (Loc, Eq_Call); + end if; + end if; + end; + + Evolve_Or_Else (Cond, Next_Test); end if; Next_Non_Pragma (C); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index b9aa4a5..e4dc06b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -72,6 +72,7 @@ with Ttypes; use Ttypes; with Uintp; use Uintp; with Urealp; use Urealp; with Validsw; use Validsw; +with Warnsw; use Warnsw; package body Exp_Ch4 is @@ -415,6 +416,52 @@ package body Exp_Ch4 is return; end Build_Boolean_Array_Proc_Call; + ----------------------- + -- Build_Eq_Call -- + ----------------------- + + function Build_Eq_Call + (Typ : Entity_Id; + Loc : Source_Ptr; + Lhs : Node_Id; + Rhs : Node_Id) return Node_Id + is + Prim : Node_Id; + Prim_E : Elmt_Id; + + begin + Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); + while Present (Prim_E) loop + Prim := Node (Prim_E); + + -- Locate primitive equality with the right signature + + if Chars (Prim) = Name_Op_Eq + and then Etype (First_Formal (Prim)) = + Etype (Next_Formal (First_Formal (Prim))) + and then Etype (Prim) = Standard_Boolean + then + if Is_Abstract_Subprogram (Prim) then + return + Make_Raise_Program_Error (Loc, + Reason => PE_Explicit_Raise); + + else + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Prim, Loc), + Parameter_Associations => New_List (Lhs, Rhs)); + end if; + end if; + + Next_Elmt (Prim_E); + end loop; + + -- If not found, predefined operation will be used + + return Empty; + end Build_Eq_Call; + -------------------------------- -- Displace_Allocator_Pointer -- -------------------------------- @@ -1938,7 +1985,7 @@ package body Exp_Ch4 is Parameter_Specifications => Formals, Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), - Declarations => Decls, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, @@ -2338,52 +2385,6 @@ package body Exp_Ch4 is Full_Type : Entity_Id; Eq_Op : Entity_Id; - function Find_Primitive_Eq return Node_Id; - -- AI05-0123: Locate primitive equality for type if it exists, and - -- build the corresponding call. If operation is abstract, replace - -- call with an explicit raise. Return Empty if there is no primitive. - - ----------------------- - -- Find_Primitive_Eq -- - ----------------------- - - function Find_Primitive_Eq return Node_Id is - Prim_E : Elmt_Id; - Prim : Node_Id; - - begin - Prim_E := First_Elmt (Collect_Primitive_Operations (Typ)); - while Present (Prim_E) loop - Prim := Node (Prim_E); - - -- Locate primitive equality with the right signature - - if Chars (Prim) = Name_Op_Eq - and then Etype (First_Formal (Prim)) = - Etype (Next_Formal (First_Formal (Prim))) - and then Etype (Prim) = Standard_Boolean - then - if Is_Abstract_Subprogram (Prim) then - return - Make_Raise_Program_Error (Loc, - Reason => PE_Explicit_Raise); - - else - return - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Prim, Loc), - Parameter_Associations => New_List (Lhs, Rhs)); - end if; - end if; - - Next_Elmt (Prim_E); - end loop; - - -- If not found, predefined operation will be used - - return Empty; - end Find_Primitive_Eq; - -- Start of processing for Expand_Composite_Equality begin @@ -2654,7 +2655,7 @@ package body Exp_Ch4 is -- a primitive equality declared for it. declare - Op : constant Node_Id := Find_Primitive_Eq; + Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs); begin -- Use user-defined primitive if it exists, otherwise use @@ -4248,9 +4249,12 @@ package body Exp_Ch4 is function Size_In_Storage_Elements (E : Entity_Id) return Node_Id; -- Given a constrained array type E, returns a node representing the - -- code to compute the size in storage elements for the given type. - -- This is done without using the attribute (which malfunctions for - -- large sizes ???) + -- code to compute a close approximation of the size in storage elements + -- for the given type; for indexes that are modular types we compute + -- 'Last - First (instead of 'Length) because for large arrays computing + -- 'Last -'First + 1 causes overflow. This is done without using the + -- attribute 'Size_In_Storage_Elements (which malfunctions for large + -- sizes ???) ------------------------- -- Rewrite_Coextension -- @@ -4309,17 +4313,77 @@ package body Exp_Ch4 is -- just a fraction of a storage element??? declare + Idx : Node_Id := First_Index (E); Len : Node_Id; Res : Node_Id; pragma Warnings (Off, Res); begin for J in 1 .. Number_Dimensions (E) loop - Len := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (E, Loc), - Attribute_Name => Name_Length, - Expressions => New_List (Make_Integer_Literal (Loc, J))); + + if not Is_Modular_Integer_Type (Etype (Idx)) then + Len := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Length, + Expressions => New_List + (Make_Integer_Literal (Loc, J))); + + -- For indexes that are modular types we cannot generate code + -- to compute 'Length since for large arrays 'Last -'First + 1 + -- causes overflow; therefore we compute 'Last - 'First (which + -- is not the exact number of components but it is valid for + -- the purpose of this runtime check on 32-bit targets) + + else + declare + Len_Minus_1_Expr : Node_Id; + Test_Gt : Node_Id; + + begin + Test_Gt := + Make_Op_Gt (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Last, + Expressions => + New_List (Make_Integer_Literal (Loc, J))), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_First, + Expressions => + New_List (Make_Integer_Literal (Loc, J)))); + + Len_Minus_1_Expr := + Convert_To (Standard_Unsigned, + Make_Op_Subtract (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Last, + Expressions => + New_List + (Make_Integer_Literal (Loc, J))), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_First, + Expressions => + New_List + (Make_Integer_Literal (Loc, J))))); + + -- Handle superflat arrays, i.e. arrays with such bounds + -- as 4 .. 2, to insure that the result is correct. + + -- Generate: + -- (if X'Last > X'First then X'Last - X'First else 0) + + Len := + Make_If_Expression (Loc, + Expressions => New_List ( + Test_Gt, + Len_Minus_1_Expr, + Make_Integer_Literal (Loc, Uint_0))); + end; + end if; if J = 1 then Res := Len; @@ -4330,6 +4394,8 @@ package body Exp_Ch4 is Left_Opnd => Res, Right_Opnd => Len); end if; + + Next_Index (Idx); end loop; return @@ -4354,6 +4420,15 @@ package body Exp_Ch4 is -- Start of processing for Expand_N_Allocator begin + -- Warn on the presence of an allocator of an anonymous access type when + -- enabled. + + if Warn_On_Anonymous_Allocators + and then Ekind (PtrT) = E_Anonymous_Access_Type + then + Error_Msg_N ("?use of an anonymous access type allocator", N); + end if; + -- RM E.2.3(22). We enforce that the expected type of an allocator -- shall not be a remote access-to-class-wide-limited-private type @@ -4563,15 +4638,83 @@ package body Exp_Ch4 is -- apply the check for constrained arrays, and manually compute the -- value of the attribute ??? - if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then - Insert_Action (N, - Make_Raise_Storage_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Size_In_Storage_Elements (Etyp), - Right_Opnd => - Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))), - Reason => SE_Object_Too_Large)); + -- The check on No_Initialization is used here to prevent generating + -- this runtime check twice when the allocator is locally replaced by + -- the expander by another one. + + if Is_Array_Type (Etyp) and then not No_Initialization (N) then + declare + Cond : Node_Id; + Ins_Nod : Node_Id := N; + Siz_Typ : Entity_Id := Etyp; + Expr : Node_Id; + + begin + -- For unconstrained array types initialized with a qualified + -- expression we use its type to perform this check + + if not Is_Constrained (Etyp) + and then not No_Initialization (N) + and then Nkind (Expression (N)) = N_Qualified_Expression + then + Expr := Expression (Expression (N)); + Siz_Typ := Etype (Expression (Expression (N))); + + -- If the qualified expression has been moved to an internal + -- temporary (to remove side effects) then we must insert + -- the runtime check before its declaration to ensure that + -- the check is performed before the execution of the code + -- computing the qualified expression. + + if Nkind (Expr) = N_Identifier + and then Is_Internal_Name (Chars (Expr)) + and then + Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Ins_Nod := Parent (Entity (Expr)); + else + Ins_Nod := Expr; + end if; + end if; + + if Is_Constrained (Siz_Typ) + and then Ekind (Siz_Typ) /= E_String_Literal_Subtype + then + -- For CCG targets the largest array may have up to 2**31-1 + -- components (i.e. 2 Gigabytes if each array component is + -- 1-byte). This insures that fat pointer fields do not + -- overflow, since they are 32-bit integer types, and also + -- insures that 'Length can be computed at run time. + + if Modify_Tree_For_C then + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Size_In_Storage_Elements (Siz_Typ), + Right_Opnd => Make_Integer_Literal (Loc, + Uint_2 ** 31 - Uint_1)); + + -- For native targets the largest object is 3.5 gigabytes + + else + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Size_In_Storage_Elements (Siz_Typ), + Right_Opnd => Make_Integer_Literal (Loc, + Uint_7 * (Uint_2 ** 29))); + end if; + + Insert_Action (Ins_Nod, + Make_Raise_Storage_Error (Loc, + Condition => Cond, + Reason => SE_Object_Too_Large)); + + if Entity (Cond) = Standard_True then + Error_Msg_N + ("object too large: Storage_Error will be raised at " + & "run time??", N); + end if; + end if; + end; end if; end if; @@ -4751,6 +4894,9 @@ package body Exp_Ch4 is -- Case of initialization procedure present, must be called + -- NOTE: There is a *huge* amount of code duplication here from + -- Build_Initialization_Call. We should probably refactor??? + else Check_Restriction (No_Default_Initialization, N); @@ -5074,7 +5220,6 @@ package body Exp_Ch4 is ------------------------------ procedure Expand_N_Case_Expression (N : Node_Id) is - function Is_Copy_Type (Typ : Entity_Id) return Boolean; -- Return True if we can copy objects of this type when expanding a case -- expression. @@ -5093,7 +5238,7 @@ package body Exp_Ch4 is or else (Minimize_Expression_With_Actions and then Is_Constrained (Underlying_Type (Typ)) - and then not Is_Limited_View (Underlying_Type (Typ))); + and then not Is_Limited_Type (Underlying_Type (Typ))); end Is_Copy_Type; -- Local variables @@ -5270,6 +5415,7 @@ package body Exp_Ch4 is declare Alt_Expr : Node_Id := Expression (Alt); Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr); + LHS : Node_Id; Stmts : List_Id; begin @@ -5299,9 +5445,12 @@ package body Exp_Ch4 is -- Target := AX['Unrestricted_Access]; else + LHS := New_Occurrence_Of (Target, Loc); + Set_Assignment_OK (LHS); + Stmts := New_List ( Make_Assignment_Statement (Alt_Loc, - Name => New_Occurrence_Of (Target, Loc), + Name => LHS, Expression => Alt_Expr)); end if; @@ -6123,6 +6272,10 @@ package body Exp_Ch4 is -- Similarly, do not rewrite membership as a validity check if -- within the predicate function for the type. + -- Finally, if the original bounds are type conversions, even + -- if they have been folded into constants, there are different + -- types involved and 'Valid is not appropriate. + then if In_Instance or else (Ekind (Current_Scope) = E_Function @@ -6130,6 +6283,11 @@ package body Exp_Ch4 is then null; + elsif Nkind (Lo_Orig) = N_Type_Conversion + or else Nkind (Hi_Orig) = N_Type_Conversion + then + null; + else Substitute_Valid_Check; goto Leave; @@ -6759,7 +6917,7 @@ package body Exp_Ch4 is -- Renaming objects in renaming associations -- This case is handled when a use of the renamed variable occurs - -- Actual parameters for a procedure call + -- Actual parameters for a subprogram call -- This case is handled in Exp_Ch6.Expand_Actuals -- The second expression in a 'Read attribute reference @@ -6780,11 +6938,12 @@ package body Exp_Ch4 is if Nkind (Parnt) = N_Unchecked_Expression then null; - elsif Nkind_In (Parnt, N_Object_Renaming_Declaration, - N_Procedure_Call_Statement) + elsif Nkind (Parnt) = N_Object_Renaming_Declaration then + return; + + elsif Nkind (Parnt) in N_Subprogram_Call or else (Nkind (Parnt) = N_Parameter_Association - and then - Nkind (Parent (Parnt)) = N_Procedure_Call_Statement) + and then Nkind (Parent (Parnt)) in N_Subprogram_Call) then return; @@ -7400,7 +7559,7 @@ package body Exp_Ch4 is -- Obj1 : Enclosing_Non_UU_Type; -- Obj2 : Enclosing_Non_UU_Type (1); - -- ... Obj1 = Obj2 ... + -- ... Obj1 = Obj2 ... -- Generated code: @@ -10124,7 +10283,6 @@ package body Exp_Ch4 is Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True); if Do_Range_Check (Operand) then - Set_Do_Range_Check (Operand, False); Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed); end if; end Expand_N_Qualified_Expression; @@ -10313,12 +10471,6 @@ package body Exp_Ch4 is Insert_Explicit_Dereference (P); Analyze_And_Resolve (P, Designated_Type (Ptyp)); - if Ekind (Etype (P)) = E_Private_Subtype - and then Is_For_Access_Subtype (Etype (P)) - then - Set_Etype (P, Base_Type (Etype (P))); - end if; - Ptyp := Etype (P); end if; @@ -10785,9 +10937,12 @@ package body Exp_Ch4 is procedure Expand_N_Type_Conversion (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Operand : constant Node_Id := Expression (N); - Target_Type : constant Entity_Id := Etype (N); + Target_Type : Entity_Id := Etype (N); Operand_Type : Entity_Id := Etype (Operand); + procedure Discrete_Range_Check; + -- Handles generation of range check for discrete target value + procedure Handle_Changed_Representation; -- This is called in the case of record and array type conversions to -- see if there is a change of representation to be handled. Change of @@ -10810,6 +10965,49 @@ package body Exp_Ch4 is -- True iff Present (Effective_Extra_Accessibility (Id)) successfully -- evaluates to True. + -------------------------- + -- Discrete_Range_Check -- + -------------------------- + + -- Case of conversions to a discrete type + + procedure Discrete_Range_Check is + Expr : Node_Id; + Ityp : Entity_Id; + + begin + -- Nothing to do if conversion was rewritten + + if Nkind (N) /= N_Type_Conversion then + return; + end if; + + Expr := Expression (N); + + -- Before we do a range check, we have to deal with treating + -- a fixed-point operand as an integer. The way we do this + -- is simply to do an unchecked conversion to an appropriate + -- integer type large enough to hold the result. + + if Is_Fixed_Point_Type (Etype (Expr)) then + if Esize (Base_Type (Etype (Expr))) > Esize (Standard_Integer) then + Ityp := Standard_Long_Long_Integer; + else + Ityp := Standard_Integer; + end if; + + Set_Do_Range_Check (Expr, False); + Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); + end if; + + -- Reset overflow flag, since the range check will include + -- dealing with possible overflow, and generate the check. + + Set_Do_Overflow_Check (N, False); + + Generate_Range_Check (Expr, Target_Type, CE_Range_Check_Failed); + end Discrete_Range_Check; + ----------------------------------- -- Handle_Changed_Representation -- ----------------------------------- @@ -11025,7 +11223,6 @@ package body Exp_Ch4 is Btyp : constant Entity_Id := Base_Type (Target_Type); Lo : constant Node_Id := Type_Low_Bound (Target_Type); Hi : constant Node_Id := Type_High_Bound (Target_Type); - Xtyp : constant Entity_Id := Etype (Operand); Conv : Node_Id; Hi_Arg : Node_Id; @@ -11049,6 +11246,12 @@ package body Exp_Ch4 is and then Hi = Type_High_Bound (Btyp)) then + -- Unset the range check flag on the current value of + -- Expression (N), since the captured Operand may have + -- been rewritten (such as for the case of a conversion + -- to a fixed-point type). + + Set_Do_Range_Check (Expression (N), False); return; end if; @@ -11058,6 +11261,7 @@ package body Exp_Ch4 is if Is_Entity_Name (Operand) and then Range_Checks_Suppressed (Entity (Operand)) then + Set_Do_Range_Check (Expression (N), False); return; end if; @@ -11067,12 +11271,12 @@ package body Exp_Ch4 is -- not trust it to be in range (might be infinite) declare - S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); - S_Hi : constant Node_Id := Type_High_Bound (Xtyp); + S_Lo : constant Node_Id := Type_Low_Bound (Operand_Type); + S_Hi : constant Node_Id := Type_High_Bound (Operand_Type); begin - if (not Is_Floating_Point_Type (Xtyp) - or else Is_Constrained (Xtyp)) + if (not Is_Floating_Point_Type (Operand_Type) + or else Is_Constrained (Operand_Type)) and then Compile_Time_Known_Value (S_Lo) and then Compile_Time_Known_Value (S_Hi) and then Compile_Time_Known_Value (Hi) @@ -11085,7 +11289,7 @@ package body Exp_Ch4 is S_Hiv : Ureal; begin - if Is_Real_Type (Xtyp) then + if Is_Real_Type (Operand_Type) then S_Lov := Expr_Value_R (S_Lo); S_Hiv := Expr_Value_R (S_Hi); else @@ -11097,30 +11301,17 @@ package body Exp_Ch4 is and then S_Lov >= D_Lov and then S_Hiv <= D_Hiv then - -- Unset the range check flag on the current value of - -- Expression (N), since the captured Operand may have - -- been rewritten (such as for the case of a conversion - -- to a fixed-point type). - Set_Do_Range_Check (Expression (N), False); - return; end if; end; end if; end; - -- For float to float conversions, we are done - - if Is_Floating_Point_Type (Xtyp) - and then - Is_Floating_Point_Type (Btyp) - then - return; - end if; - -- Otherwise rewrite the conversion as described above + Set_Do_Range_Check (Expression (N), False); + Conv := Relocate_Node (N); Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); Set_Etype (Conv, Btyp); @@ -11129,7 +11320,7 @@ package body Exp_Ch4 is -- where it is never required, since we can never have overflow in -- this case. - if not Is_Integer_Type (Etype (Operand)) then + if not Is_Integer_Type (Operand_Type) then Enable_Overflow_Check (Conv); end if; @@ -11468,6 +11659,7 @@ package body Exp_Ch4 is then if not Comes_From_Source (N) and then Nkind_In (Parent (N), N_Function_Call, + N_Parameter_Association, N_Procedure_Call_Statement) and then Is_Interface (Designated_Type (Target_Type)) and then Is_Class_Wide_Type (Designated_Type (Target_Type)) @@ -11750,31 +11942,21 @@ package body Exp_Ch4 is then Set_Rounded_Result (N); Set_Etype (N, Etype (Parent (N))); + Target_Type := Etype (N); end if; - -- Otherwise do correct fixed-conversion, but skip these if the - -- Conversion_OK flag is set, because from a semantic point of view - -- these are simple integer conversions needing no further processing - -- (the backend will simply treat them as integers). - - if not Conversion_OK (N) then - if Is_Fixed_Point_Type (Etype (N)) then - Expand_Convert_Fixed_To_Fixed (N); - Real_Range_Check; - - elsif Is_Integer_Type (Etype (N)) then - Expand_Convert_Fixed_To_Integer (N); - - -- The result of the conversion might need a range check, so do - -- not assume that the result is in bounds. + if Is_Fixed_Point_Type (Target_Type) then + Expand_Convert_Fixed_To_Fixed (N); + Real_Range_Check; - Set_Etype (N, Base_Type (Target_Type)); + elsif Is_Integer_Type (Target_Type) then + Expand_Convert_Fixed_To_Integer (N); + Discrete_Range_Check; - else - pragma Assert (Is_Floating_Point_Type (Etype (N))); - Expand_Convert_Fixed_To_Float (N); - Real_Range_Check; - end if; + else + pragma Assert (Is_Floating_Point_Type (Target_Type)); + Expand_Convert_Fixed_To_Float (N); + Real_Range_Check; end if; -- Case of conversions to a fixed-point type @@ -11796,42 +11978,6 @@ package body Exp_Ch4 is Real_Range_Check; end if; - -- Case of float-to-integer conversions - - -- We also handle float-to-fixed conversions with Conversion_OK set - -- since semantically the fixed-point target is treated as though it - -- were an integer in such cases. - - elsif Is_Floating_Point_Type (Operand_Type) - and then - (Is_Integer_Type (Target_Type) - or else - (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N))) - then - -- One more check here, gcc is still not able to do conversions of - -- this type with proper overflow checking, and so gigi is doing an - -- approximation of what is required by doing floating-point compares - -- with the end-point. But that can lose precision in some cases, and - -- give a wrong result. Converting the operand to Universal_Real is - -- helpful, but still does not catch all cases with 64-bit integers - -- on targets with only 64-bit floats. - - -- The above comment seems obsoleted by Apply_Float_Conversion_Check - -- Can this code be removed ??? - - if Do_Range_Check (Operand) then - Rewrite (Operand, - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Universal_Real, Loc), - Expression => - Relocate_Node (Operand))); - - Set_Etype (Operand, Universal_Real); - Enable_Range_Check (Operand); - Set_Do_Range_Check (Expression (Operand), False); - end if; - -- Case of array conversions -- Expansion of array conversions, add required length/range checks but @@ -11914,11 +12060,6 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Target_Type); end if; - - -- Case of conversions to floating-point - - elsif Is_Floating_Point_Type (Target_Type) then - Real_Range_Check; end if; -- At this stage, either the conversion node has been transformed into @@ -11936,80 +12077,54 @@ package body Exp_Ch4 is -- Check: are these rules stated in sinfo??? if so, why restate here??? -- The only remaining step is to generate a range check if we still have - -- a type conversion at this stage and Do_Range_Check is set. For now we - -- do this only for conversions of discrete types and for float-to-float - -- conversions. - - if Nkind (N) = N_Type_Conversion then + -- a type conversion at this stage and Do_Range_Check is set. Note that + -- we need to deal with at most 8 out of the 9 possible cases of numeric + -- conversions here, because the float-to-integer case is entirely dealt + -- with by Apply_Float_Conversion_Check. - -- For now we only support floating-point cases where both source - -- and target are floating-point types. Conversions where the source - -- and target involve integer or fixed-point types are still TBD, - -- though not clear whether those can even happen at this point, due - -- to transformations above. ??? + if Nkind (N) = N_Type_Conversion + and then Do_Range_Check (Expression (N)) + then + -- Float-to-float conversions - if Is_Floating_Point_Type (Etype (N)) + if Is_Floating_Point_Type (Target_Type) and then Is_Floating_Point_Type (Etype (Expression (N))) then - if Do_Range_Check (Expression (N)) - and then Is_Floating_Point_Type (Target_Type) - then - Generate_Range_Check - (Expression (N), Target_Type, CE_Range_Check_Failed); - end if; + -- Reset overflow flag, since the range check will include + -- dealing with possible overflow, and generate the check. - -- Discrete-to-discrete conversions + Set_Do_Overflow_Check (N, False); - elsif Is_Discrete_Type (Etype (N)) then - declare - Expr : constant Node_Id := Expression (N); - Ftyp : Entity_Id; - Ityp : Entity_Id; + Generate_Range_Check + (Expression (N), Target_Type, CE_Range_Check_Failed); - begin - if Do_Range_Check (Expr) - and then Is_Discrete_Type (Etype (Expr)) - then - Set_Do_Range_Check (Expr, False); + -- Discrete-to-discrete conversions or fixed-point-to-discrete + -- conversions when Conversion_OK is set. - -- Before we do a range check, we have to deal with treating - -- a fixed-point operand as an integer. The way we do this - -- is simply to do an unchecked conversion to an appropriate - -- integer type large enough to hold the result. - - -- This code is not active yet, because we are only dealing - -- with discrete types so far ??? - - if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer - and then Treat_Fixed_As_Integer (Expr) - then - Ftyp := Base_Type (Etype (Expr)); - - if Esize (Ftyp) >= Esize (Standard_Integer) then - Ityp := Standard_Long_Long_Integer; - else - Ityp := Standard_Integer; - end if; - - Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); - end if; + elsif Is_Discrete_Type (Target_Type) + and then (Is_Discrete_Type (Etype (Expression (N))) + or else (Is_Fixed_Point_Type (Etype (Expression (N))) + and then Conversion_OK (N))) + then + -- If Address is either a source type or target type, + -- suppress range check to avoid typing anomalies when + -- it is a visible integer type. - -- Reset overflow flag, since the range check will include - -- dealing with possible overflow, and generate the check. - -- If Address is either a source type or target type, - -- suppress range check to avoid typing anomalies when - -- it is a visible integer type. + if Is_Descendant_Of_Address (Etype (Expression (N))) + or else Is_Descendant_Of_Address (Target_Type) + then + Set_Do_Range_Check (Expression (N), False); + else + Discrete_Range_Check; + end if; - Set_Do_Overflow_Check (N, False); + -- Conversions to floating- or fixed-point when Conversion_OK is set - if not Is_Descendant_Of_Address (Etype (Expr)) - and then not Is_Descendant_Of_Address (Target_Type) - then - Generate_Range_Check - (Expr, Target_Type, CE_Range_Check_Failed); - end if; - end if; - end; + elsif Is_Floating_Point_Type (Target_Type) + or else (Is_Fixed_Point_Type (Target_Type) + and then Conversion_OK (N)) + then + Real_Range_Check; end if; end if; @@ -12032,10 +12147,13 @@ package body Exp_Ch4 is begin -- Avoid infinite recursion on the subsequent expansion of - -- of the copy of the original type conversion. + -- of the copy of the original type conversion. When needed, + -- a range check has already been applied to the expression. Set_Comes_From_Source (New_Expr, False); - Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr)); + Insert_Action (N, + Make_Predicate_Check (Target_Type, New_Expr), + Suppress => Range_Check); end; end if; end Expand_N_Type_Conversion; @@ -12391,6 +12509,10 @@ package body Exp_Ch4 is -- For Opnd a boolean expression, return a Boolean expression equivalent -- to Opnd /= Shortcut_Value. + function Useful (Actions : List_Id) return Boolean; + -- Return True if Actions is not empty and contains useful nodes to + -- process. + -------------------- -- Make_Test_Expr -- -------------------- @@ -12404,6 +12526,31 @@ package body Exp_Ch4 is end if; end Make_Test_Expr; + ------------ + -- Useful -- + ------------ + + function Useful (Actions : List_Id) return Boolean is + L : Node_Id; + begin + if Present (Actions) then + L := First (Actions); + + -- For now "useful" means not N_Variable_Reference_Marker. + -- Consider stripping other nodes in the future. + + while Present (L) loop + if Nkind (L) /= N_Variable_Reference_Marker then + return True; + end if; + + Next (L); + end loop; + end if; + + return False; + end Useful; + -- Local variables Op_Var : Entity_Id; @@ -12463,7 +12610,7 @@ package body Exp_Ch4 is -- must only be executed if the right operand of the short circuit is -- executed and not otherwise. - if Present (Actions (N)) then + if Useful (Actions (N)) then Actlist := Actions (N); -- The old approach is to expand: @@ -12567,7 +12714,7 @@ package body Exp_Ch4 is Adjust_Result_Type (N, Typ); end Expand_Short_Circuit_Operator; - ------------------------------------- + ------------------------------------ -- Fixup_Universal_Fixed_Operation -- ------------------------------------- @@ -12587,13 +12734,13 @@ package body Exp_Ch4 is if Nkind (Parent (Conv)) = N_Attribute_Reference and then Attribute_Name (Parent (Conv)) = Name_Round then - Set_Etype (N, Etype (Parent (Conv))); + Set_Etype (N, Base_Type (Etype (Parent (Conv)))); Set_Rounded_Result (N); -- Normal case where type comes from conversion above us else - Set_Etype (N, Etype (Conv)); + Set_Etype (N, Base_Type (Etype (Conv))); end if; end Fixup_Universal_Fixed_Operation; @@ -14122,7 +14269,8 @@ package body Exp_Ch4 is -- Obj1 in DT'Class; -- Compile time error -- Obj1 in Iface'Class; -- Compile time error - if not Is_Class_Wide_Type (Left_Type) + if not Is_Interface (Left_Type) + and then not Is_Class_Wide_Type (Left_Type) and then (Is_Ancestor (Etype (Right_Type), Left_Type, Use_Full_View => True) or else (Is_Interface (Etype (Right_Type)) diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index 5ff9fc4..44872fd 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -74,13 +74,26 @@ package Exp_Ch4 is procedure Expand_N_Unchecked_Expression (N : Node_Id); procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id); + function Build_Eq_Call + (Typ : Entity_Id; + Loc : Source_Ptr; + Lhs : Node_Id; + Rhs : Node_Id) return Node_Id; + -- AI05-0123: Locate primitive equality for type if it exists, and build + -- the corresponding call. If operation is abstract, replace call with + -- an explicit raise. Return Empty if there is no primitive. + -- Used in the construction of record-equality routines for records here + -- and for variant records in exp_ch3.adb. These two paths are distinct + -- for historical but also technical reasons: for variant records the + -- constructed function includes a case statement with nested returns, + -- while for records without variants only a simple expression is needed. + function Expand_Record_Equality (Nod : Node_Id; Typ : Entity_Id; Lhs : Node_Id; Rhs : Node_Id; - Bodies : List_Id) - return Node_Id; + Bodies : List_Id) return Node_Id; -- Expand a record equality into an expression that compares the fields -- individually to yield the required Boolean result. Loc is the -- location for the generated nodes. Typ is the type of the record, and diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index b1b0f55..682c855 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2021,15 +2021,21 @@ package body Exp_Ch5 is if not Suppress_Assignment_Checks (N) then - -- First deal with generation of range check if required + -- First deal with generation of range check if required, + -- and then predicate checks if the type carries a predicate. + -- If the Rhs is an expression these tests may have been applied + -- already. This is the case if the RHS is a type conversion. + -- Other such redundant checks could be removed ??? + + if Nkind (Rhs) /= N_Type_Conversion + or else Entity (Subtype_Mark (Rhs)) /= Typ + then + if Do_Range_Check (Rhs) then + Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed); + end if; - if Do_Range_Check (Rhs) then - Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed); + Apply_Predicate_Check (Rhs, Typ); end if; - - -- Then generate predicate check if required - - Apply_Predicate_Check (Rhs, Typ); end if; -- Check for a special case where a high level transformation is @@ -2850,13 +2856,14 @@ package body Exp_Ch5 is ----------------------------- procedure Expand_N_Case_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Expr : constant Node_Id := Expression (N); - Alt : Node_Id; - Len : Nat; - Cond : Node_Id; - Choice : Node_Id; - Chlist : List_Id; + Loc : constant Source_Ptr := Sloc (N); + Expr : constant Node_Id := Expression (N); + From_Cond_Expr : constant Boolean := From_Conditional_Expression (N); + Alt : Node_Id; + Len : Nat; + Cond : Node_Id; + Choice : Node_Id; + Chlist : List_Id; begin -- Check for the situation where we know at compile time which branch @@ -3067,7 +3074,15 @@ package body Exp_Ch5 is Condition => Cond, Then_Statements => Then_Stms, Else_Statements => Else_Stms)); + + -- The rewritten if statement needs to inherit whether the + -- case statement was expanded from a conditional expression, + -- for proper handling of nested controlled objects. + + Set_From_Conditional_Expression (N, From_Cond_Expr); + Analyze (N); + return; end if; end if; @@ -3304,7 +3319,7 @@ package body Exp_Ch5 is Declarations => New_List (Elmt_Decl), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stats)))); + Statements => Stats)))); else Elmt_Ref := @@ -3330,7 +3345,7 @@ package body Exp_Ch5 is Declarations => New_List (Elmt_Decl), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (New_Loop))); + Statements => New_List (New_Loop))); end if; -- The element is only modified in expanded code, so it appears as @@ -3919,7 +3934,7 @@ package body Exp_Ch5 is -- -- Default_Iterator aspect of Vector. This increments Lock, -- -- disallowing tampering with cursors. Unfortunately, it does not -- -- increment Busy. The result of Iterate is Limited_Controlled; - -- -- finalization will decrement Lock. This is a build-in-place + -- -- finalization will decrement Lock. This is a build-in-place -- -- dispatching call to Iterate. -- Cur : Cursor := First (Iter); -- or Last diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index bd7ae2c..f38dd67 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2319,6 +2319,13 @@ package body Exp_Ch6 is -- Adds invariant checks for every intermediate type between the range -- of a view converted argument to its ancestor (from parent to child). + function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean; + -- Try to constant-fold a predicate check, which often enough is a + -- simple arithmetic expression that can be computed statically if + -- its argument is static. This cleans up the output of CCG, even + -- though useless predicate checks will be generally removed by + -- back-end optimizations. + function Inherited_From_Formal (S : Entity_Id) return Entity_Id; -- Within an instance, a type derived from an untagged formal derived -- type inherits from the original parent, not from the actual. The @@ -2331,6 +2338,10 @@ package body Exp_Ch6 is function In_Unfrozen_Instance (E : Entity_Id) return Boolean; -- Return true if E comes from an instance that is not yet frozen + function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean; + -- Return True when E is a class-wide interface type or an access to + -- a class-wide interface type. + function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean; -- Determine if Subp denotes a non-dispatching call to a Deep routine @@ -2463,6 +2474,113 @@ package body Exp_Ch6 is end if; end Add_View_Conversion_Invariants; + ----------------------------- + -- Can_Fold_Predicate_Call -- + ----------------------------- + + function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is + Actual : Node_Id; + + function May_Fold (N : Node_Id) return Traverse_Result; + -- The predicate expression is foldable if it only contains operators + -- and literals. During this check, we also replace occurrences of + -- the formal of the constructed predicate function with the static + -- value of the actual. This is done on a copy of the analyzed + -- expression for the predicate. + + -------------- + -- May_Fold -- + -------------- + + function May_Fold (N : Node_Id) return Traverse_Result is + begin + case Nkind (N) is + when N_Binary_Op + | N_Unary_Op + => + return OK; + + when N_Expanded_Name + | N_Identifier + => + if Ekind (Entity (N)) = E_In_Parameter + and then Entity (N) = First_Entity (P) + then + Rewrite (N, New_Copy (Actual)); + Set_Is_Static_Expression (N); + return OK; + + elsif Ekind (Entity (N)) = E_Enumeration_Literal then + return OK; + + else + return Abandon; + end if; + + when N_Case_Expression + | N_If_Expression + => + return OK; + + when N_Integer_Literal => + return OK; + + when others => + return Abandon; + end case; + end May_Fold; + + function Try_Fold is new Traverse_Func (May_Fold); + + -- Other lLocal variables + + Subt : constant Entity_Id := Etype (First_Entity (P)); + Aspect : Node_Id; + Pred : Node_Id; + + -- Start of processing for Can_Fold_Predicate_Call + + begin + -- Folding is only interesting if the actual is static and its type + -- has a Dynamic_Predicate aspect. For CodePeer we preserve the + -- function call. + + Actual := First (Parameter_Associations (Call_Node)); + Aspect := Find_Aspect (Subt, Aspect_Dynamic_Predicate); + + -- If actual is a declared constant, retrieve its value + + if Is_Entity_Name (Actual) + and then Ekind (Entity (Actual)) = E_Constant + then + Actual := Constant_Value (Entity (Actual)); + end if; + + if No (Actual) + or else Nkind (Actual) /= N_Integer_Literal + or else not Has_Dynamic_Predicate_Aspect (Subt) + or else No (Aspect) + or else CodePeer_Mode + then + return False; + end if; + + -- Retrieve the analyzed expression for the predicate + + Pred := New_Copy_Tree (Expression (Aspect)); + + if Try_Fold (Pred) = OK then + Rewrite (Call_Node, Pred); + Analyze_And_Resolve (Call_Node, Standard_Boolean); + return True; + + -- Otherwise continue the expansion of the function call + + else + return False; + end if; + end Can_Fold_Predicate_Call; + --------------------------- -- Inherited_From_Formal -- --------------------------- @@ -2585,6 +2703,32 @@ package body Exp_Ch6 is return False; end In_Unfrozen_Instance; + ---------------------------------- + -- Is_Class_Wide_Interface_Type -- + ---------------------------------- + + function Is_Class_Wide_Interface_Type (E : Entity_Id) return Boolean is + DDT : Entity_Id; + Typ : Entity_Id := E; + + begin + if Has_Non_Limited_View (Typ) then + Typ := Non_Limited_View (Typ); + end if; + + if Ekind (Typ) = E_Anonymous_Access_Type then + DDT := Directly_Designated_Type (Typ); + + if Has_Non_Limited_View (DDT) then + DDT := Non_Limited_View (DDT); + end if; + + return Is_Class_Wide_Type (DDT) and then Is_Interface (DDT); + else + return Is_Class_Wide_Type (Typ) and then Is_Interface (Typ); + end if; + end Is_Class_Wide_Interface_Type; + ------------------------- -- Is_Direct_Deep_Call -- ------------------------- @@ -2785,6 +2929,17 @@ package body Exp_Ch6 is end; end if; + -- if this is a call to a predicate function, try to constant + -- fold it. + + if Nkind (Call_Node) = N_Function_Call + and then Is_Entity_Name (Name (Call_Node)) + and then Is_Predicate_Function (Subp) + and then Can_Fold_Predicate_Call (Subp) + then + return; + end if; + if Modify_Tree_For_C and then Nkind (Call_Node) = N_Function_Call and then Is_Entity_Name (Name (Call_Node)) @@ -2919,15 +3074,7 @@ package body Exp_Ch6 is CW_Interface_Formals_Present := CW_Interface_Formals_Present - or else - (Is_Class_Wide_Type (Etype (Formal)) - and then Is_Interface (Etype (Etype (Formal)))) - or else - (Ekind (Etype (Formal)) = E_Anonymous_Access_Type - and then Is_Class_Wide_Type (Directly_Designated_Type - (Etype (Etype (Formal)))) - and then Is_Interface (Directly_Designated_Type - (Etype (Etype (Formal))))); + or else Is_Class_Wide_Interface_Type (Etype (Formal)); -- Create possible extra actual for constrained case. Usually, the -- extra actual is of the form actual'constrained, but since this @@ -3203,7 +3350,7 @@ package body Exp_Ch6 is -- ??? -- A further case that requires special handling - -- is the common idiom E.all'access. If E is a + -- is the common idiom E.all'access. If E is a -- formal of the enclosing subprogram, the -- accessibility of the expression is that of E. @@ -3271,7 +3418,10 @@ package body Exp_Ch6 is -- For allocators we pass the level of the execution of the -- called subprogram, which is one greater than the current - -- scope level. + -- scope level. However, according to RM 3.10.2(14/3) this + -- is wrong since for an anonymous allocator defining the + -- value of an access parameter, the accessibility level is + -- that of the innermost master of the call??? when N_Allocator => Add_Extra_Actual @@ -7765,22 +7915,20 @@ package body Exp_Ch6 is -- For now we test whether E denotes a function or access-to-function -- type whose result subtype is inherently limited. Later this test - -- may be revised to allow composite nonlimited types. Functions with - -- a foreign convention or whose result type has a foreign convention - -- never qualify. + -- may be revised to allow composite nonlimited types. if Ekind_In (E, E_Function, E_Generic_Function) or else (Ekind (E) = E_Subprogram_Type and then Etype (E) /= Standard_Void_Type) then - -- Note: If the function has a foreign convention, it cannot build - -- its result in place, so you're on your own. On the other hand, - -- if only the return type has a foreign convention, its layout is - -- intended to be compatible with the other language, but the build- - -- in place machinery can ensure that the object is not copied. + -- If the function is imported from a foreign language, we don't do + -- build-in-place. Note that Import (Ada) functions can do + -- build-in-place. Note that it is OK for a build-in-place function + -- to return a type with a foreign convention; the build-in-place + -- machinery will ensure there is no copying. return Is_Build_In_Place_Result_Type (Etype (E)) - and then not Has_Foreign_Convention (E) + and then not (Has_Foreign_Convention (E) and then Is_Imported (E)) and then not Debug_Flag_Dot_L; else return False; @@ -8524,7 +8672,7 @@ package body Exp_Ch6 is -- The presence of an address clause complicates the build-in-place -- expansion because the indicated address must be processed before -- the indirect call is generated (including the definition of a - -- local pointer to the object). The address clause may come from + -- local pointer to the object). The address clause may come from -- an aspect specification or from an explicit attribute -- specification appearing after the object declaration. These two -- cases require different processing. @@ -9235,8 +9383,9 @@ package body Exp_Ch6 is return False; end Has_Unconstrained_Access_Discriminant_Component; - Feature_Disabled : constant Boolean := True; - -- Temporary + Disable_Coextension_Cases : constant Boolean := True; + -- Flag used to temporarily disable a "True" result for types with + -- access discriminants and related coextension cases. -- Start of processing for Needs_Result_Accessibility_Level @@ -9246,9 +9395,6 @@ package body Exp_Ch6 is if not Present (Func_Typ) then return False; - elsif Feature_Disabled then - return False; - -- False if not a function, also handle enum-lit renames case elsif Func_Typ = Standard_Void_Type @@ -9273,23 +9419,37 @@ package body Exp_Ch6 is elsif Ada_Version < Ada_2012 then return False; - elsif Ekind (Func_Typ) = E_Anonymous_Access_Type - or else Is_Tagged_Type (Func_Typ) - then - -- In the case of, say, a null tagged record result type, the need - -- for this extra parameter might not be obvious. This function - -- returns True for all tagged types for compatibility reasons. - -- A function with, say, a tagged null controlling result type might - -- be overridden by a primitive of an extension having an access - -- discriminant and the overrider and overridden must have compatible - -- calling conventions (including implicitly declared parameters). - -- Similarly, values of one access-to-subprogram type might designate - -- both a primitive subprogram of a given type and a function - -- which is, for example, not a primitive subprogram of any type. - -- Again, this requires calling convention compatibility. - -- It might be possible to solve these issues by introducing - -- wrappers, but that is not the approach that was chosen. + -- Handle the situation where a result is an anonymous access type + -- RM 3.10.2 (10.3/3). + + elsif Ekind (Func_Typ) = E_Anonymous_Access_Type then + return True; + + -- The following cases are related to coextensions and do not fully + -- cover everything mentioned in RM 3.10.2 (12) ??? + + -- Temporarily disabled ??? + + elsif Disable_Coextension_Cases then + return False; + + -- In the case of, say, a null tagged record result type, the need for + -- this extra parameter might not be obvious so this function returns + -- True for all tagged types for compatibility reasons. + + -- A function with, say, a tagged null controlling result type might + -- be overridden by a primitive of an extension having an access + -- discriminant and the overrider and overridden must have compatible + -- calling conventions (including implicitly declared parameters). + + -- Similarly, values of one access-to-subprogram type might designate + -- both a primitive subprogram of a given type and a function which is, + -- for example, not a primitive subprogram of any type. Again, this + -- requires calling convention compatibility. It might be possible to + -- solve these issues by introducing wrappers, but that is not the + -- approach that was chosen. + elsif Is_Tagged_Type (Func_Typ) then return True; elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 4209785..b00fc92 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -393,7 +393,7 @@ package body Exp_Ch7 is -- name. Before generating the proper call to one of these operations we -- check whether Typ is known to be controlled at the point of definition. -- If it is not then we must retrieve the hidden operation of the parent - -- and use it instead. This is one case that might be solved more cleanly + -- and use it instead. This is one case that might be solved more cleanly -- once Overriding pragmas or declarations are in place. function Contains_Subprogram (Blk : Entity_Id) return Boolean; @@ -2035,6 +2035,13 @@ package body Exp_Ch7 is Analyze (Fin_Body, Suppress => All_Checks); end if; + + -- Never consider that the finalizer procedure is enabled Ghost, even + -- when the corresponding unit is Ghost, as this would lead to an + -- an external name with a ___ghost_ prefix that the binder cannot + -- generate, as it has no knowledge of the Ghost status of units. + + Set_Is_Checked_Ghost_Entity (Fin_Id, False); end Create_Finalizer; -------------------------- @@ -3873,7 +3880,7 @@ package body Exp_Ch7 is Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, Dim))))), - Statements => Free_One_Dimension (Dim + 1))); + Statements => Free_One_Dimension (Dim + 1))); end if; end Free_One_Dimension; @@ -3893,11 +3900,12 @@ package body Exp_Ch7 is Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (N); - Tsk : Node_Id; - Comp : Entity_Id; Stmts : constant List_Id := New_List; U_Typ : constant Entity_Id := Underlying_Type (Typ); + Comp : Entity_Id; + Tsk : Node_Id; + begin if Has_Discriminants (U_Typ) and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration @@ -3918,7 +3926,7 @@ package body Exp_Ch7 is return New_List (Make_Null_Statement (Loc)); end if; - Comp := First_Component (Typ); + Comp := First_Component (U_Typ); while Present (Comp) loop if Has_Task (Etype (Comp)) or else Has_Simple_Protected_Object (Etype (Comp)) @@ -3937,8 +3945,8 @@ package body Exp_Ch7 is elsif Is_Record_Type (Etype (Comp)) then - -- Recurse, by generating the prefix of the argument to - -- the eventual cleanup call. + -- Recurse, by generating the prefix of the argument to the + -- eventual cleanup call. Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp))); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 0f83d57..99bd8d2 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -477,12 +477,11 @@ package body Exp_Ch9 is -- <actualN> := P.<formalN>; procedure Reset_Scopes_To (Bod : Node_Id; E : Entity_Id); - -- Reset the scope of declarations and blocks at the top level of Bod - -- to be E. Bod is either a block or a subprogram body. Used after - -- expanding various kinds of entry bodies into their corresponding - -- constructs. This is needed during unnesting to determine whether a - -- body generated for an entry or an accept alternative includes uplevel - -- references. + -- Reset the scope of declarations and blocks at the top level of Bod to + -- be E. Bod is either a block or a subprogram body. Used after expanding + -- various kinds of entry bodies into their corresponding constructs. This + -- is needed during unnesting to determine whether a body generated for an + -- entry or an accept alternative includes uplevel references. function Trivial_Accept_OK return Boolean; -- If there is no DO-END block for an accept, or if the DO-END block has @@ -869,7 +868,7 @@ package body Exp_Ch9 is Make_Implicit_Exception_Handler (Loc, Exception_Choices => New_List (Ohandle), - Statements => New_List ( + Statements => New_List ( Make_Procedure_Call_Statement (Sloc (Stats), Name => New_Occurrence_Of ( RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), @@ -3494,6 +3493,8 @@ package body Exp_Ch9 is procedure Move_Pragmas (From : Node_Id; To : Node_Id); -- Find all suitable source pragmas at the top of subprogram body From's -- declarations and insert them after arbitrary node To. + -- + -- Very similar to Move_Pragmas in sem_ch6 ??? --------------------- -- Analyze_Pragmas -- @@ -3545,7 +3546,14 @@ package body Exp_Ch9 is Next_Decl := Next (Decl); - if Nkind (Decl) = N_Pragma then + -- We add an exception here for Unreferenced pragmas since the + -- internally generated spec gets analyzed within + -- Build_Private_Protected_Declaration and will lead to spurious + -- warnings due to the way references are checked. + + if Nkind (Decl) = N_Pragma + and then Pragma_Name_Unmapped (Decl) /= Name_Unreferenced + then Remove (Decl); Insert_After (Insert_Nod, Decl); Insert_Nod := Decl; @@ -3792,7 +3800,7 @@ package body Exp_Ch9 is Make_Implicit_Exception_Handler (EH_Loc, Exception_Choices => New_List (Ohandle), - Statements => New_List ( + Statements => New_List ( Make_Procedure_Call_Statement (EH_Loc, Name => Complete, Parameter_Associations => New_List ( @@ -3887,6 +3895,7 @@ package body Exp_Ch9 is if Unprotected then Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); + Set_Ekind (Defining_Identifier (New_Param), Ekind (Formal)); end if; Append (New_Param, New_Plist); @@ -8919,6 +8928,8 @@ package body Exp_Ch9 is Current_Node : Node_Id := N; E_Count : Int; Entries_Aggr : Node_Id; + Rec_Decl : Node_Id; + Rec_Id : Entity_Id; procedure Check_Inlining (Subp : Entity_Id); -- If the original operation has a pragma Inline, propagate the flag @@ -8940,6 +8951,21 @@ package body Exp_Ch9 is -- For a protected operation that is an interrupt handler, add the -- freeze action that will register it as such. + procedure Replace_Access_Definition (Comp : Node_Id); + -- If a private component of the type is an access to itself, this + -- is not a reference to the current instance, but an access type out + -- of which one might construct a list. If such a component exists, we + -- create an incomplete type for the equivalent record type, and + -- a named access type for it, that replaces the access definition + -- of the original component. This is similar to what is done for + -- records in Check_Anonymous_Access_Components, but simpler, because + -- the corresponding record type has no previous declaration. + -- This needs to be done only once, even if there are several such + -- access components. The following entity stores the constructed + -- access type. + + Acc_T : Entity_Id := Empty; + -------------------- -- Check_Inlining -- -------------------- @@ -9087,6 +9113,41 @@ package body Exp_Ch9 is Append_Freeze_Action (Prot_Proc, RTS_Call); end Register_Handler; + ------------------------------- + -- Replace_Access_Definition -- + ------------------------------- + + procedure Replace_Access_Definition (Comp : Node_Id) is + Loc : constant Source_Ptr := Sloc (Comp); + Inc_T : Node_Id; + Inc_D : Node_Id; + Acc_Def : Node_Id; + Acc_D : Node_Id; + + begin + if No (Acc_T) then + Inc_T := Make_Defining_Identifier (Loc, Chars (Rec_Id)); + Inc_D := Make_Incomplete_Type_Declaration (Loc, Inc_T); + Acc_T := Make_Temporary (Loc, 'S'); + Acc_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => New_Occurrence_Of (Inc_T, Loc)); + Acc_D := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_T, + Type_Definition => Acc_Def); + + Insert_Before (Rec_Decl, Inc_D); + Analyze (Inc_D); + + Insert_Before (Rec_Decl, Acc_D); + Analyze (Acc_D); + end if; + + Set_Access_Definition (Comp, Empty); + Set_Subtype_Indication (Comp, New_Occurrence_Of (Acc_T, Loc)); + end Replace_Access_Definition; + -- Local variables Body_Arr : Node_Id; @@ -9098,7 +9159,6 @@ package body Exp_Ch9 is Obj_Def : Node_Id; Object_Comp : Node_Id; Priv : Node_Id; - Rec_Decl : Node_Id; Sub : Node_Id; -- Start of processing for Expand_N_Protected_Type_Declaration @@ -9108,6 +9168,7 @@ package body Exp_Ch9 is return; else Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); + Rec_Id := Defining_Identifier (Rec_Decl); end if; Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); @@ -9253,6 +9314,15 @@ package body Exp_Ch9 is Access_Definition => New_Copy_Tree (Access_Definition (Old_Comp), Discr_Map)); + + -- A self-reference in the private part becomes a + -- self-reference to the corresponding record. + + if Entity (Subtype_Mark (Access_Definition (New_Comp))) + = Prot_Typ + then + Replace_Access_Definition (New_Comp); + end if; end if; New_Priv := @@ -10639,7 +10709,7 @@ package body Exp_Ch9 is Statements => New_List ( Make_Implicit_If_Statement (N, - Condition => Cond, + Condition => Cond, Then_Statements => New_List ( Make_Select_Call ( New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), @@ -12658,14 +12728,6 @@ package body Exp_Ch9 is Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), Expression => D_Disc)); - -- Do the assignment at this stage only because the evaluation of the - -- expression must not occur earlier (see ACVC C97302A). - - Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (D, Loc), - Expression => D_Conv)); - -- Parameter block processing -- Manually create the parameter block for dispatching calls. In the @@ -12674,6 +12736,14 @@ package body Exp_Ch9 is if Is_Disp_Select then + -- Compute the delay at this stage because the evaluation of its + -- expression must not occur earlier (see ACVC C97302A). + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (D, Loc), + Expression => D_Conv)); + -- Tagged kind processing, generate: -- K : Ada.Tags.Tagged_Kind := -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); @@ -12855,8 +12925,8 @@ package body Exp_Ch9 is Next (Stmt); end loop; - -- Do the assignment at this stage only because the evaluation - -- of the expression must not occur earlier (see ACVC C97302A). + -- Compute the delay at this stage because the evaluation of + -- its expression must not occur earlier (see ACVC C97302A). Insert_Before (Stmt, Make_Assignment_Statement (Loc, @@ -12942,10 +13012,9 @@ package body Exp_Ch9 is Analyze (N); - -- Some items in Decls used to be in the N_Block in E_Call that - -- is constructed in Expand_Entry_Call, and are now in the new - -- Block into which N has been rewritten. Adjust their scopes - -- to reflect that. + -- Some items in Decls used to be in the N_Block in E_Call that is + -- constructed in Expand_Entry_Call, and are now in the new Block + -- into which N has been rewritten. Adjust their scopes to reflect that. if Nkind (E_Call) = N_Block_Statement then Obj := First_Entity (Entity (Identifier (E_Call))); @@ -14882,7 +14951,8 @@ package body Exp_Ch9 is -- Ditto for a package declaration or a full type declaration, etc. - elsif Nkind (N) = N_Package_Declaration + elsif (Nkind (N) = N_Package_Declaration + and then N /= Specification (N)) or else Nkind (N) in N_Declaration or else Nkind (N) in N_Renaming_Declaration then diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 388d247..f0df5e2 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -914,6 +914,14 @@ package body Exp_Dbug is -- names produced for Ghost entities, while "__ghost_" can appear in -- names of entities inside a child/local package called "Ghost". + -- The compiler-generated finalizer for an enabled Ghost unit is treated + -- specially, as its name must be known to the binder, which has no + -- knowledge of Ghost status. In that case, the finalizer is not marked + -- as Ghost so that no prefix is added. Note that the special ___ghost_ + -- prefix is retained when the Ghost unit is ignored, which still allows + -- inspecting the final executable for the presence of an ignored Ghost + -- finalizer procedure. + if Is_Ghost_Entity (E) and then not Is_Compilation_Unit (E) and then (Name_Len < 9 diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 1b21234..4fae37c 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1682,18 +1682,34 @@ package body Exp_Disp is while Present (Formal) loop Formal_Typ := Etype (Formal); + if Has_Non_Limited_View (Formal_Typ) then + Formal_Typ := Non_Limited_View (Formal_Typ); + end if; + if Ekind (Formal_Typ) = E_Record_Type_With_Private then Formal_Typ := Full_View (Formal_Typ); end if; if Is_Access_Type (Formal_Typ) then Formal_DDT := Directly_Designated_Type (Formal_Typ); + + if Has_Non_Limited_View (Formal_DDT) then + Formal_DDT := Non_Limited_View (Formal_DDT); + end if; end if; Actual_Typ := Etype (Actual); + if Has_Non_Limited_View (Actual_Typ) then + Actual_Typ := Non_Limited_View (Actual_Typ); + end if; + if Is_Access_Type (Actual_Typ) then Actual_DDT := Directly_Designated_Type (Actual_Typ); + + if Has_Non_Limited_View (Actual_DDT) then + Actual_DDT := Non_Limited_View (Actual_DDT); + end if; end if; if Is_Interface (Formal_Typ) @@ -7637,7 +7653,7 @@ package body Exp_Disp is Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of (Alias (Prim), Loc), + New_Occurrence_Of (Ultimate_Alias (Prim), Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 6a8d626..a47de2f 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -69,18 +69,23 @@ package body Exp_Imgv is ------------------------------------ procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (E); - Str : String_Id; + Loc : constant Source_Ptr := Sloc (E); + + Eind : Entity_Id; + Estr : Entity_Id; Ind : List_Id; + Ityp : Node_Id; + Len : Nat; Lit : Entity_Id; Nlit : Nat; - Len : Nat; - Estr : Entity_Id; - Eind : Entity_Id; - Ityp : Node_Id; + Str : String_Id; + + Saved_SSO : constant Character := Opt.Default_SSO; + -- Used to save the current scalar storage order during the generation + -- of the literal lookup table. begin - -- Nothing to do for other than a root enumeration type + -- Nothing to do for types other than a root enumeration type if E /= Root_Type (E) then return; @@ -138,6 +143,15 @@ package body Exp_Imgv is Set_Lit_Strings (E, Estr); Set_Lit_Indexes (E, Eind); + -- Temporarily set the current scalar storage order to the default + -- during the generation of the literals table, since both the Image and + -- Value attributes rely on runtime routines for interpreting table + -- values. + + Opt.Default_SSO := ' '; + + -- Generate literal table + Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, @@ -168,6 +182,10 @@ package body Exp_Imgv is Make_Aggregate (Loc, Expressions => Ind))), Suppress => All_Checks); + + -- Reset the scalar storage order to the saved value + + Opt.Default_SSO := Saved_SSO; end Build_Enumeration_Image_Tables; ---------------------------- @@ -433,13 +451,13 @@ package body Exp_Imgv is -- Local variables + Enum_Case : Boolean; Imid : RE_Id; + Proc_Ent : Entity_Id; Ptyp : Entity_Id; Rtyp : Entity_Id; Tent : Entity_Id := Empty; Ttyp : Entity_Id; - Proc_Ent : Entity_Id; - Enum_Case : Boolean; Arg_List : List_Id; -- List of arguments for run-time procedure call @@ -450,6 +468,8 @@ package body Exp_Imgv is Snn : constant Entity_Id := Make_Temporary (Loc, 'S'); Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + -- Start of processing for Expand_Image_Attribute + begin if Is_Object_Image (Pref) then Rewrite_Object_Image (N, Pref, Name_Image, Standard_String); diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index a7d2a0d..2f45a72 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -1022,7 +1022,9 @@ package body Exp_Pakd is Ass_OK : constant Boolean := Assignment_OK (Lhs); -- Used to preserve assignment OK status when assignment is rewritten - Rhs : Node_Id := Expression (N); + Expr : Node_Id; + + Rhs : Node_Id := Expression (N); -- Initially Rhs is the right hand side value, it will be replaced -- later by an appropriate unchecked conversion for the assignment. @@ -1125,7 +1127,7 @@ package body Exp_Pakd is -- If we are building the initialization procedure for a packed array, -- and Initialize_Scalars is enabled, each component assignment is an - -- out-of-range value by design. Compile this value without checks, + -- out-of-range value by design. Compile this value without checks, -- because a call to the array init_proc must not raise an exception. -- Condition is not consistent with description above, Within_Init_Proc @@ -1140,6 +1142,36 @@ package body Exp_Pakd is Analyze_And_Resolve (Rhs, Ctyp); end if; + -- If any of the indices has a nonstandard representation, introduce + -- the proper Rep_To_Pos conversion, which in turn will generate index + -- checks when needed. We do this on a copy of the index expression, + -- rather that rewriting the LHS altogether. + + Expr := First (Expressions (Lhs)); + while Present (Expr) loop + declare + Expr_Typ : constant Entity_Id := Etype (Expr); + Loc : constant Source_Ptr := Sloc (Expr); + + Expr_Copy : Node_Id; + + begin + if Is_Enumeration_Type (Expr_Typ) + and then Has_Non_Standard_Rep (Expr_Typ) + then + Expr_Copy := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Expr_Typ, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List (Relocate_Node (Expr))); + Set_Parent (Expr_Copy, N); + Analyze_And_Resolve (Expr_Copy, Standard_Natural); + end if; + end; + + Next (Expr); + end loop; + -- Case of component size 1,2,4 or any component size for the modular -- case. These are the cases for which we can inline the code. diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index b008c79..63f2dad 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -26,6 +26,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; +with Exp_Attr; with Exp_Ch4; with Exp_Ch5; use Exp_Ch5; with Exp_Dbug; use Exp_Dbug; @@ -196,6 +197,12 @@ package body Exp_SPARK is Parameter_Associations => New_List (Expr))); Analyze_And_Resolve (N, Typ); + -- Whenever possible, replace a prefix which is an enumeration literal + -- by the corresponding literal value. + + elsif Attr_Id = Attribute_Enum_Rep then + Exp_Attr.Expand_N_Attribute_Reference (N); + -- For attributes which return Universal_Integer, introduce a conversion -- to the expected type with the appropriate check flags set. @@ -515,12 +522,6 @@ package body Exp_SPARK is Insert_Explicit_Dereference (Pref); Analyze_And_Resolve (Pref, Designated_Type (Typ)); - - if Ekind (Etype (Pref)) = E_Private_Subtype - and then Is_For_Access_Subtype (Etype (Pref)) - then - Set_Etype (Pref, Base_Type (Etype (Pref))); - end if; end if; end Expand_SPARK_N_Selected_Component; diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index 388be48..8ef05e2 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -32,6 +32,7 @@ with Lib; use Lib; with Restrict; use Restrict; with Rident; use Rident; with Sem_Aux; use Sem_Aux; +with Sem_Ch6; use Sem_Ch6; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -275,8 +276,8 @@ package body Exp_Tss is then exit; - elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type - and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type + elsif not Is_Anonymous_Access_Type (Etype (E1)) + and then not Is_Anonymous_Access_Type (Etype (E2)) and then Etype (E1) /= Etype (E2) then exit; @@ -287,6 +288,17 @@ package body Exp_Tss is /= Directly_Designated_Type (Etype (E2)) then exit; + + elsif Ekind_In (Etype (E1), + E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) + and then Ekind_In (Etype (E2), + E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) + and then not Conforming_Types + (Etype (E1), Etype (E2), Fully_Conformant) + then + exit; end if; E1 := Next_Formal (E1); diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index b81b1b9..f146a6f 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -598,6 +598,33 @@ package body Exp_Unst is then Note_Uplevel_Bound (Prefix (N), Ref); + -- Conditional expressions + + elsif Nkind (N) = N_If_Expression then + declare + Expr : Node_Id; + + begin + Expr := First (Expressions (N)); + while Present (Expr) loop + Note_Uplevel_Bound (Expr, Ref); + Next (Expr); + end loop; + end; + + elsif Nkind (N) = N_Case_Expression then + declare + Alternative : Node_Id; + + begin + Note_Uplevel_Bound (Expression (N), Ref); + + Alternative := First (Alternatives (N)); + while Present (Alternative) loop + Note_Uplevel_Bound (Expression (Alternative), Ref); + end loop; + end; + -- Conversion case elsif Nkind (N) = N_Type_Conversion then diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4206090..b677a72 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -343,7 +343,7 @@ package body Exp_Util is return; end if; - -- Case of zero/non-zero semantics or non-standard enumeration + -- Case of zero/nonzero semantics or nonstandard enumeration -- representation. In each case, we rewrite the node as: -- ityp!(N) /= False'Enum_Rep @@ -4492,7 +4492,7 @@ package body Exp_Util is begin -- E is the package or generic package which is externally axiomatized - if Ekind_In (E, E_Generic_Package, E_Package) + if Is_Package_Or_Generic_Package (E) and then Has_Annotate_Pragma_For_External_Axiomatization (E) then return E; @@ -5067,9 +5067,13 @@ package body Exp_Util is -- may be constants that depend on the bounds of a string literal, both -- standard string types and more generally arrays of characters. - -- In GNATprove mode, these extra subtypes are not needed + -- In GNATprove mode, these extra subtypes are not needed, unless Exp is + -- a static expression. In that case, the subtype will be constrained + -- while the original type might be unconstrained, so expanding the type + -- is necessary both for passing legality checks in GNAT and for precise + -- analysis in GNATprove. - if GNATprove_Mode then + if GNATprove_Mode and then not Is_Static_Expression (Exp) then return; end if; @@ -5094,7 +5098,7 @@ package body Exp_Util is -- This subtype indication may be used later for constraint checks -- we better make sure that if a variable was used as a bound of - -- of the original slice, its value is frozen. + -- the original slice, its value is frozen. Evaluate_Slice_Bounds (Exp); end; @@ -5614,7 +5618,7 @@ package body Exp_Util is -- We can retrieve primitive operations by name if it is an internal -- name. For equality we must check that both of its operands have -- the same type, to avoid confusion with user-defined equalities - -- than may have a non-symmetric signature. + -- than may have a asymmetric signature. exit when Chars (Op) = Name and then @@ -6818,8 +6822,8 @@ package body Exp_Util is N := Assoc_Node; P := Parent (Assoc_Node); - -- Non-subexpression case. Note that N is initially Empty in this case - -- (N is only guaranteed Non-Empty in the subexpr case). + -- Nonsubexpression case. Note that N is initially Empty in this case + -- (N is only guaranteed non-Empty in the subexpr case). else N := Empty; @@ -8341,7 +8345,7 @@ package body Exp_Util is S : Nat; begin - -- If component reference is for an array with non-static bounds, + -- If component reference is for an array with nonstatic bounds, -- then it is always aligned: we can only process unaligned arrays -- with static bounds (more precisely compile time known bounds). @@ -9063,7 +9067,7 @@ package body Exp_Util is then Constr_Root := Root_Typ; - -- At this point in the expansion, non-limited view of the type + -- At this point in the expansion, nonlimited view of the type -- must be available, otherwise the error will be reported later. if From_Limited_With (Constr_Root) @@ -9836,7 +9840,7 @@ package body Exp_Util is -- in the derivation chain starting from parent type Par_Typ leading to -- derived type Deriv_Typ. The returned value is one of the following: -- - -- * An entity which is either a discriminant or a non-discriminant + -- * An entity which is either a discriminant or a nondiscriminant -- name, and renames/constraints Discr. -- -- * An expression which constraints Discr @@ -10550,94 +10554,6 @@ package body Exp_Util is end if; end Needs_Constant_Address; - ------------------------ - -- Needs_Finalization -- - ------------------------ - - function Needs_Finalization (Typ : Entity_Id) return Boolean is - function Has_Some_Controlled_Component - (Input_Typ : Entity_Id) return Boolean; - -- Determine whether type Input_Typ has at least one controlled - -- component. - - ----------------------------------- - -- Has_Some_Controlled_Component -- - ----------------------------------- - - function Has_Some_Controlled_Component - (Input_Typ : Entity_Id) return Boolean - is - Comp : Entity_Id; - - begin - -- When a type is already frozen and has at least one controlled - -- component, or is manually decorated, it is sufficient to inspect - -- flag Has_Controlled_Component. - - if Has_Controlled_Component (Input_Typ) then - return True; - - -- Otherwise inspect the internals of the type - - elsif not Is_Frozen (Input_Typ) then - if Is_Array_Type (Input_Typ) then - return Needs_Finalization (Component_Type (Input_Typ)); - - elsif Is_Record_Type (Input_Typ) then - Comp := First_Component (Input_Typ); - while Present (Comp) loop - if Needs_Finalization (Etype (Comp)) then - return True; - end if; - - Next_Component (Comp); - end loop; - end if; - end if; - - return False; - end Has_Some_Controlled_Component; - - -- Start of processing for Needs_Finalization - - begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. - - if Restriction_Active (No_Finalization) then - return False; - - -- C++ types are not considered controlled. It is assumed that the non- - -- Ada side will handle their clean up. - - elsif Convention (Typ) = Convention_CPP then - return False; - - -- Class-wide types are treated as controlled because derivations from - -- the root type may introduce controlled components. - - elsif Is_Class_Wide_Type (Typ) then - return True; - - -- Concurrent types are controlled as long as their corresponding record - -- is controlled. - - elsif Is_Concurrent_Type (Typ) - and then Present (Corresponding_Record_Type (Typ)) - and then Needs_Finalization (Corresponding_Record_Type (Typ)) - then - return True; - - -- Otherwise the type is controlled when it is either derived from type - -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or - -- contains at least one controlled component. - - else - return - Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); - end if; - end Needs_Finalization; - ---------------------------- -- New_Class_Wide_Subtype -- ---------------------------- @@ -11329,7 +11245,17 @@ package body Exp_Util is -- Generate: -- Rnn : Exp_Type renames Expr; - if Renaming_Req then + -- In GNATprove mode, we prefer to use renamings for intermediate + -- variables to definition of constants, due to the implicit move + -- operation that such a constant definition causes as part of the + -- support in GNATprove for ownership pointers. Hence, we generate + -- a renaming for a reference to an object of a nonscalar type. + + if Renaming_Req + or else (GNATprove_Mode + and then Is_Object_Reference (Exp) + and then not Is_Scalar_Type (Exp_Type)) + then E := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Def_Id, @@ -11451,7 +11377,7 @@ package body Exp_Util is -- For expressions that denote names, we can use a renaming scheme. -- This is needed for correctness in the case of a volatile object of - -- a non-volatile type because the Make_Reference call of the "default" + -- a nonvolatile type because the Make_Reference call of the "default" -- approach would generate an illegal access value (an access value -- cannot designate such an object - see Analyze_Reference). @@ -11473,7 +11399,7 @@ package body Exp_Util is Name => Relocate_Node (Exp))); -- If this is a packed reference, or a selected component with - -- a non-standard representation, a reference to the temporary + -- a nonstandard representation, a reference to the temporary -- will be replaced by a copy of the original expression (see -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be -- elaborated by gigi, and is of course not to be replaced in-line @@ -11687,6 +11613,10 @@ package body Exp_Util is Set_Assignment_OK (Res, Assignment_OK (Exp)); + -- Preserve the Do_Range_Check flag in all copies + + Set_Do_Range_Check (Res, Do_Range_Check (Exp)); + -- Finally rewrite the original expression and we are done Rewrite (Exp, Res); @@ -12079,7 +12009,7 @@ package body Exp_Util is and then Nkind_In (N, N_Package_Body, N_Package_Specification); -- N is at the library level if the top-most context is a package and - -- the path taken to reach N does not inlcude non-package constructs. + -- the path taken to reach N does not include nonpackage constructs. begin case Nkind (N) is @@ -12152,9 +12082,7 @@ package body Exp_Util is Typ : Entity_Id; begin - if No (L) - or else Is_Empty_List (L) - then + if No (L) or else Is_Empty_List (L) then return False; end if; @@ -12766,7 +12694,7 @@ package body Exp_Util is -- Mark the assignment statement as elaboration code. This allows -- the early call region mechanism (see Sem_Elab) to properly - -- ignore such assignments even though they are non-preelaborable + -- ignore such assignments even though they are nonpreelaborable -- code. Set_Is_Elaboration_Code (Asn); diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 7cb9d2d..c0848c7 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -944,10 +944,6 @@ package Exp_Util is -- consist of constants, when the object has a nontrivial initialization -- or is controlled. - function Needs_Finalization (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ is controlled and this requires finalization - -- actions. - function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id; -- An anonymous access type may designate a limited view. Check whether -- non-limited view is available during expansion, to examine components diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 11711b9..aac2e7d 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -112,7 +112,12 @@ package body Expander is Expand_SPARK (N); end if; - Set_Analyzed (N, Full_Analysis); + -- Do not reset the Analyzed flag if it has been set on purpose + -- during preanalysis. + + if Full_Analysis then + Set_Analyzed (N); + end if; -- Regular expansion is normally followed by special handling for -- transient scopes for unconstrained results, etc. but this is not diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c index 76fce78..349af3f 100644 --- a/gcc/ada/expect.c +++ b/gcc/ada/expect.c @@ -29,14 +29,11 @@ * * ****************************************************************************/ -#ifdef __alpha_vxworks -#include "vxWorks.h" -#endif - #ifdef IN_RTS #define POSIX -#include "tconfig.h" -#include "tsystem.h" +#include "runtime.h" +#include <unistd.h> + #else #include "config.h" #include "system.h" diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads index 90b2ef3..3e62c47 100644 --- a/gcc/ada/fname-uf.ads +++ b/gcc/ada/fname-uf.ads @@ -105,7 +105,7 @@ package Fname.UF is Dot : String_Ptr; Cas : Casing_Type); -- This is called to process a Source_File_Name pragma whose first - -- argument is a file name pattern string. Pat is this pattern string, + -- argument is a file name pattern string. Pat is this pattern string, -- which contains an asterisk to correspond to the unit. Typ is one of -- 'b'/'s'/'u' for body/spec/subunit, Dot is the separator string -- for child/subunit names, and Cas is one of Lower/Upper/Mixed diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5b843f2..00d20e9 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -62,6 +62,7 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -407,11 +408,14 @@ package body Freeze is -- calls to the renamed entity. The body must be generated in any case -- for calls that may appear elsewhere. This is not done in the case -- where the subprogram is an instantiation because the actual proper - -- body has not been built yet. + -- body has not been built yet. This is also not done in GNATprove mode + -- as we need to check other conditions for creating a body to inline + -- in that case, which are controlled in Analyze_Subprogram_Body_Helper. if Ekind_In (Old_S, E_Function, E_Procedure) and then Nkind (Decl) = N_Subprogram_Declaration and then not Is_Generic_Instance (Old_S) + and then not GNATprove_Mode then Set_Body_To_Inline (Decl, Old_S); end if; @@ -7999,6 +8003,7 @@ package body Freeze is Brng : constant Node_Id := Scalar_Range (Btyp); BLo : constant Node_Id := Low_Bound (Brng); BHi : constant Node_Id := High_Bound (Brng); + Par : constant Entity_Id := First_Subtype (Typ); Small : constant Ureal := Small_Value (Typ); Loval : Ureal; Hival : Ureal; @@ -8051,6 +8056,16 @@ package body Freeze is end if; end if; + -- The 'small attribute may have been specified with an aspect, + -- in which case it is processed after a subtype declaration, so + -- inherit now the specified value. + + if Typ /= Par + and then Present (Find_Aspect (Par, Aspect_Small)) + then + Set_Small_Value (Typ, Small_Value (Par)); + end if; + -- Immediate return if the range is already analyzed. This means that -- the range is already set, and does not need to be computed by this -- routine. @@ -8763,6 +8778,20 @@ package body Freeze is Set_Is_Pure (E, False); end if; + -- For C++ constructors check that their external name has been given + -- (either in pragma CPP_Constructor or in a pragma import). + + if Is_Constructor (E) + and then + (No (Interface_Name (E)) + or else String_Equal + (L => Strval (Interface_Name (E)), + R => Strval (Get_Default_External_Name (E)))) + then + Error_Msg_N + ("'C++ constructor must have external name or link name", E); + end if; + -- We also reset the Pure indication on a subprogram with an Address -- parameter, because the parameter may be used as a pointer and the -- referenced data may change even if the address value does not. diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index dd90c7b..b6a337a 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -355,6 +355,7 @@ GNAT_ADA_OBJS = \ ada/prep.o \ ada/prepcomp.o \ ada/put_scos.o \ + ada/repinfo-input.o \ ada/repinfo.o \ ada/restrict.o \ ada/rident.o \ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 32dd132..6cd3759 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -6276,13 +6276,17 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) Node_Id gnat_pragma; /* Make the decl for the elaboration procedure. Emit debug info for it, so that users can break into their elaboration code in debuggers. Kludge: - don't consider it as a definition so that we have a line map for its body, - but no subprogram description in debug info. */ + don't consider it as a definition so that we have a line map for its + body, but no subprogram description in debug info. In addition, don't + qualify it as artificial, even though it is not a user subprogram per se, + in particular for specs. Unlike, say, clones created internally by the + compiler, this subprogram materializes specific user code and flagging it + artificial would take elab code away from gcov's analysis. */ tree gnu_elab_proc_decl = create_subprog_decl (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"), NULL_TREE, void_ftype, NULL_TREE, - is_default, true, false, true, true, false, NULL, gnat_unit); + is_default, true, false, false, true, false, NULL, gnat_unit); struct elab_info *info; vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl); diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index 27cf190..bf6df5e 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -179,12 +179,6 @@ procedure Get_SCOs is Skipc; C := Nextc; exit when C /= LF and then C /= CR; - - if C = ' ' then - Skip_Spaces; - C := Nextc; - exit when C /= LF and then C /= CR; - end if; end loop; end Skip_EOL; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 1f5817a..ecb3ccd 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -51,6 +51,7 @@ with Output; use Output; with Par_SCO; with Prepcomp; with Repinfo; +with Repinfo.Input; with Restrict; with Rident; use Rident; with Rtsfind; @@ -61,10 +62,11 @@ with Sem_Ch12; with Sem_Ch13; with Sem_Elim; with Sem_Eval; -with Sem_SPARK; use Sem_SPARK; +with Sem_Prag; with Sem_Type; with Set_Targ; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Sinput.L; use Sinput.L; with Snames; use Snames; with Sprint; use Sprint; @@ -81,6 +83,7 @@ with Uname; use Uname; with Urealp; with Usage; with Validsw; use Validsw; +with Warnsw; use Warnsw; with System.Assertions; with System.OS_Lib; @@ -112,6 +115,12 @@ procedure Gnat1drv is -- the information provided by the back end in back annotation of declared -- entities (e.g. actual size and alignment values chosen by the back end). + procedure Read_JSON_Files_For_Repinfo; + -- This procedure exercises the JSON parser of Repinfo by reading back the + -- JSON files generated by -gnatRjs in a previous compilation session. It + -- is intended to make sure that the JSON generator and the JSON parser are + -- kept synchronized when the JSON format evolves. + ---------------------------- -- Adjust_Global_Switches -- ---------------------------- @@ -318,7 +327,12 @@ procedure Gnat1drv is Elaboration_Check => True, others => False); - Dynamic_Elaboration_Checks := False; + -- Need to enable dynamic elaboration checks to disable strict + -- static checking performed by gnatbind. We are at the same time + -- suppressing actual compile time elaboration checks to simplify + -- the generated code. + + Dynamic_Elaboration_Checks := True; -- Set STRICT mode for overflow checks if not set explicitly. This -- prevents suppressing of overflow checks by default, in code down @@ -379,8 +393,7 @@ procedure Gnat1drv is -- enough useful info. Reset_Validity_Check_Options; - Validity_Check_Default := True; - Validity_Check_Copies := True; + Set_Validity_Check_Options ("dc"); Check_Validity_Of_Parameters := False; -- Turn off style check options and ignore any style check pragmas @@ -403,7 +416,22 @@ procedure Gnat1drv is Relaxed_RM_Semantics := True; - if not Generate_CodePeer_Messages then + if Generate_CodePeer_Messages then + + -- We do want to emit GNAT warnings when using -gnateC. But, + -- in CodePeer mode, warnings about memory representation are not + -- meaningful, thus, suppress them. + + Warn_On_Biased_Representation := False; -- -gnatw.b + Warn_On_Unrepped_Components := False; -- -gnatw.c + Warn_On_Record_Holes := False; -- -gnatw.h + Warn_On_Unchecked_Conversion := False; -- -gnatwz + Warn_On_Size_Alignment := False; -- -gnatw.z + Warn_On_Questionable_Layout := False; -- -gnatw.q + Warn_On_Overridden_Size := False; -- -gnatw.s + Warn_On_Reverse_Bit_Order := False; -- -gnatw.v + + else -- Suppress compiler warnings by default when generating SCIL for -- CodePeer, except when combined with -gnateC where we do want to @@ -991,7 +1019,7 @@ procedure Gnat1drv is Atree.Unlock; Nlists.Unlock; Sem.Unlock; - Sem_Ch13.Validate_Compile_Time_Warning_Errors; + Sem_Prag.Validate_Compile_Time_Warning_Errors; Sem.Lock; Nlists.Lock; Atree.Lock; @@ -1016,6 +1044,39 @@ procedure Gnat1drv is -- end if; end Post_Compilation_Validation_Checks; + ----------------------------------- + -- Read_JSON_Files_For_Repinfo -- + ----------------------------------- + + procedure Read_JSON_Files_For_Repinfo is + begin + -- This is the same loop construct as in Repinfo.List_Rep_Info + + for U in Main_Unit .. Last_Unit loop + if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then + declare + Nam : constant String := + Get_Name_String + (File_Name (Source_Index (U))) & ".json"; + Namid : constant File_Name_Type := Name_Enter (Nam); + Index : constant Source_File_Index := Load_Config_File (Namid); + + begin + if Index = No_Source_File then + Write_Str ("cannot locate "); + Write_Line (Nam); + raise Unrecoverable_Error; + end if; + + Repinfo.Input.Read_JSON_Stream (Source_Text (Index).all, Nam); + exception + when Repinfo.Input.Invalid_JSON_Stream => + raise Unrecoverable_Error; + end; + end if; + end loop; + end Read_JSON_Files_For_Repinfo; + -- Local variables Back_End_Mode : Back_End.Back_End_Mode_Type; @@ -1082,7 +1143,6 @@ begin -- Acquire target parameters from system.ads (package System source) Targparm_Acquire : declare - use Sinput; S : Source_File_Index; N : File_Name_Type; @@ -1525,13 +1585,6 @@ begin if GNATprove_Mode then - -- Perform the new SPARK checking rules for pointer aliasing. This is - -- only activated in GNATprove mode and on SPARK code. - - if Debug_Flag_FF then - Check_Safe_Pointers (Main_Unit_Node); - end if; - -- In GNATprove mode we're writing the ALI much earlier than usual -- as flow analysis needs the file present in order to append its -- own globals to it. @@ -1550,6 +1603,12 @@ begin Par_SCO.SCO_Record_Filtered; end if; + -- If -gnatd_j is specified, exercise the JSON parser of Repinfo + + if Debug_Flag_Underscore_J then + Read_JSON_Files_For_Repinfo; + end if; + -- Back end needs to explicitly unlock tables it needs to touch Atree.Lock; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 39a24ab..257c394 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -729,6 +729,7 @@ The GNAT Library * GNAT.Array_Split (g-arrspl.ads): GNAT Array_Split g-arrspl ads. * GNAT.AWK (g-awk.ads): GNAT AWK g-awk ads. * GNAT.Bind_Environment (g-binenv.ads): GNAT Bind_Environment g-binenv ads. +* GNAT.Branch_Prediction (g-brapre.ads): GNAT Branch_Prediction g-brapre ads. * GNAT.Bounded_Buffers (g-boubuf.ads): GNAT Bounded_Buffers g-boubuf ads. * GNAT.Bounded_Mailboxes (g-boumai.ads): GNAT Bounded_Mailboxes g-boumai ads. * GNAT.Bubble_Sort (g-bubsor.ads): GNAT Bubble_Sort g-bubsor ads. @@ -2103,7 +2104,7 @@ case, and it is recommended that these two options not be used together. Syntax: @example -pragma Asynch_Readers [ (boolean_EXPRESSION) ]; +pragma Async_Readers [ (boolean_EXPRESSION) ]; @end example For the semantics of this pragma, see the entry for aspect @code{Async_Readers} in @@ -2117,7 +2118,7 @@ the SPARK 2014 Reference Manual, section 7.1.2. Syntax: @example -pragma Asynch_Writers [ (boolean_EXPRESSION) ]; +pragma Async_Writers [ (boolean_EXPRESSION) ]; @end example For the semantics of this pragma, see the entry for aspect @code{Async_Writers} in @@ -3870,7 +3871,7 @@ then the name will be forced to all lowercase letters. A specification of taken from the string provided. @end itemize -This pragma may appear anywhere that a pragma is valid. In particular, it +This pragma may appear anywhere that a pragma is valid. In particular, it can be used as a configuration pragma in the @code{gnat.adc} file, in which case it applies to all subsequent compilations, or it can be used as a program unit pragma, in which case it only applies to the current unit, or it can @@ -4441,58 +4442,102 @@ in the SPARK 2014 Reference Manual, section 7.1.6. Syntax: @example -pragma Initialize_Scalars; +pragma Initialize_Scalars + [ ( TYPE_VALUE_PAIR @{, TYPE_VALUE_PAIR@} ) ]; + +TYPE_VALUE_PAIR ::= + SCALAR_TYPE => static_EXPRESSION + +SCALAR_TYPE := + Short_Float +| Float +| Long_Float +| Long_Long_Flat +| Signed_8 +| Signed_16 +| Signed_32 +| Signed_64 +| Unsigned_8 +| Unsigned_16 +| Unsigned_32 +| Unsigned_64 @end example -This pragma is similar to @code{Normalize_Scalars} conceptually but has -two important differences. First, there is no requirement for the pragma -to be used uniformly in all units of a partition, in particular, it is fine -to use this just for some or all of the application units of a partition, -without needing to recompile the run-time library. - -In the case where some units are compiled with the pragma, and some without, -then a declaration of a variable where the type is defined in package -Standard or is locally declared will always be subject to initialization, -as will any declaration of a scalar variable. For composite variables, -whether the variable is initialized may also depend on whether the package -in which the type of the variable is declared is compiled with the pragma. - -The other important difference is that you can control the value used -for initializing scalar objects. At bind time, you can select several -options for initialization. You can -initialize with invalid values (similar to Normalize_Scalars, though for -Initialize_Scalars it is not always possible to determine the invalid -values in complex cases like signed component fields with non-standard -sizes). You can also initialize with high or -low values, or with a specified bit pattern. See the GNAT -User's Guide for binder options for specifying these cases. - -This means that you can compile a program, and then without having to -recompile the program, you can run it with different values being used -for initializing otherwise uninitialized values, to test if your program -behavior depends on the choice. Of course the behavior should not change, -and if it does, then most likely you have an incorrect reference to an -uninitialized value. - -It is even possible to change the value at execution time eliminating even -the need to rebind with a different switch using an environment variable. -See the GNAT User's Guide for details. +This pragma is similar to @code{Normalize_Scalars} conceptually but has two +important differences. + +First, there is no requirement for the pragma to be used uniformly in all units +of a partition. In particular, it is fine to use this just for some or all of +the application units of a partition, without needing to recompile the run-time +library. In the case where some units are compiled with the pragma, and some +without, then a declaration of a variable where the type is defined in package +Standard or is locally declared will always be subject to initialization, as +will any declaration of a scalar variable. For composite variables, whether the +variable is initialized may also depend on whether the package in which the +type of the variable is declared is compiled with the pragma. + +The other important difference is that the programmer can control the value +used for initializing scalar objects. This effect can be achieved in several +different ways: + + +@itemize * + +@item +At compile time, the programmer can specify the invalid value for a +particular family of scalar types using the optional arguments of the pragma. + +The compile-time approach is intended to optimize the generated code for the +pragma, by possibly using fast operations such as @code{memset}. + +@item +At bind time, the programmer has several options: + + +@itemize * + +@item +Initialization with invalid values (similar to Normalize_Scalars, though +for Initialize_Scalars it is not always possible to determine the invalid +values in complex cases like signed component fields with nonstandard +sizes). + +@item +Initialization with high values. -Note that pragma @code{Initialize_Scalars} is particularly useful in -conjunction with the enhanced validity checking that is now provided -in GNAT, which checks for invalid values under more conditions. -Using this feature (see description of the @emph{-gnatV} flag in the -GNAT User's Guide) in conjunction with -pragma @code{Initialize_Scalars} -provides a powerful new tool to assist in the detection of problems -caused by uninitialized variables. - -Note: the use of @code{Initialize_Scalars} has a fairly extensive -effect on the generated code. This may cause your code to be -substantially larger. It may also cause an increase in the amount -of stack required, so it is probably a good idea to turn on stack -checking (see description of stack checking in the GNAT -User's Guide) when using this pragma. +@item +Initialization with low values. + +@item +Initialization with a specific bit pattern. +@end itemize + +See the GNAT User's Guide for binder options for specifying these cases. + +The bind-time approach is intended to provide fast turnaround for testing +with different values, without having to recompile the program. + +@item +At execution time, the programmer can speify the invalid values using an +environment variable. See the GNAT User's Guide for details. + +The execution-time approach is intended to provide fast turnaround for +testing with different values, without having to recompile and rebind the +program. +@end itemize + +Note that pragma @code{Initialize_Scalars} is particularly useful in conjunction +with the enhanced validity checking that is now provided in GNAT, which checks +for invalid values under more conditions. Using this feature (see description +of the @emph{-gnatV} flag in the GNAT User's Guide) in conjunction with pragma +@code{Initialize_Scalars} provides a powerful new tool to assist in the detection +of problems caused by uninitialized variables. + +Note: the use of @code{Initialize_Scalars} has a fairly extensive effect on the +generated code. This may cause your code to be substantially larger. It may +also cause an increase in the amount of stack required, so it is probably a +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 pragma-initializes}@anchor{83}@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{84} @@ -8779,11 +8824,10 @@ $ gcc -c -gnatVim ... @end itemize The form ALL_CHECKS activates all standard checks (its use is equivalent -to the use of the @code{gnatva} switch. +to the use of the @code{gnatVa} switch). -The forms with @code{Off} and @code{On} -can be used to temporarily disable validity checks -as shown in the following example: +The forms with @code{Off} and @code{On} can be used to temporarily disable +validity checks as shown in the following example: @example pragma Validity_Checks ("c"); -- validity checks for copies @@ -10669,16 +10713,16 @@ indicates whether or not the corresponding actual type has discriminants. @geindex Img -The @code{Img} attribute differs from @code{Image} in that it is applied -directly to an object, and yields the same result as -@code{Image} for the subtype of the object. This is convenient for -debugging: +The @code{Img} attribute differs from @code{Image} in that, while both can be +applied directly to an object, @code{Img} cannot be applied to types. + +Example usage of the attribute: @example Put_Line ("X = " & X'Img); @end example -has the same meaning as the more verbose: +which has the same meaning as the more verbose: @example Put_Line ("X = " & T'Image (X)); @@ -11227,8 +11271,8 @@ for Date'Scalar_Storage_Order use System.High_Order_First; -- the former is used. @end example -Other properties are as for standard representation attribute @code{Bit_Order}, -as defined by Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}. +Other properties are as for the standard representation attribute @code{Bit_Order} +defined by Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}. For a record type @code{T}, if @code{T'Scalar_Storage_Order} is specified explicitly, it shall be equal to @code{T'Bit_Order}. Note: @@ -11238,8 +11282,8 @@ specified explicitly and set to the same value. Derived types inherit an explicitly set scalar storage order from their parent types. This may be overridden for the derived type by giving an explicit scalar -storage order for the derived type. For a record extension, the derived type -must have the same scalar storage order as the parent type. +storage order for it. However, for a record extension, the derived type must +have the same scalar storage order as the parent type. A component of a record type that is itself a record or an array and that does not start and end on a byte boundary must have have the same scalar storage @@ -11289,15 +11333,18 @@ inheritance in the case of a derived type), then the default is normally the native ordering of the target, but this default can be overridden using pragma @code{Default_Scalar_Storage_Order}. -Note that if a component of @code{T} is itself of a record or array type, -the specfied @code{Scalar_Storage_Order} does @emph{not} apply to that nested type: -an explicit attribute definition clause must be provided for the component -type as well if desired. +If a component of @code{T} is itself of a record or array type, the specfied +@code{Scalar_Storage_Order} does @emph{not} apply to that nested type: an explicit +attribute definition clause must be provided for the component type as well +if desired. Note that the scalar storage order only affects the in-memory data representation. It has no effect on the representation used by stream attributes. +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{e7}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19c} @section Attribute Simple_Storage_Pool @@ -12464,7 +12511,8 @@ of exceptions when they are declared. @geindex No_Exceptions [RM H.4] This restriction ensures at compile time that there are no -raise statements and no exception handlers. +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{1d2} @@ -12839,7 +12887,7 @@ user-defined storage pool. [GNAT] This restriction affects the performance of stream operations on types @code{String}, @code{Wide_String} and @code{Wide_Wide_String}. By default, the compiler uses block reads and writes when manipulating @code{String} objects -due to their supperior performance. When this restriction is in effect, the +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 @@ -22966,6 +23014,7 @@ of GNAT, and will generate a warning message. * GNAT.Array_Split (g-arrspl.ads): GNAT Array_Split g-arrspl ads. * GNAT.AWK (g-awk.ads): GNAT AWK g-awk ads. * GNAT.Bind_Environment (g-binenv.ads): GNAT Bind_Environment g-binenv ads. +* GNAT.Branch_Prediction (g-brapre.ads): GNAT Branch_Prediction g-brapre ads. * GNAT.Bounded_Buffers (g-boubuf.ads): GNAT Bounded_Buffers g-boubuf ads. * GNAT.Bounded_Mailboxes (g-boumai.ads): GNAT Bounded_Mailboxes g-boumai ads. * GNAT.Bubble_Sort (g-bubsor.ads): GNAT Bubble_Sort g-bubsor ads. @@ -23772,7 +23821,7 @@ Provides AWK-like parsing functions, with an easy interface for parsing one 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 Bounded_Buffers g-boubuf ads,GNAT AWK g-awk ads,The GNAT Library +@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{326}@anchor{gnat_rm/the_gnat_library id45}@anchor{327} @section @code{GNAT.Bind_Environment} (@code{g-binenv.ads}) @@ -23785,8 +23834,19 @@ Provides access to key=value associations captured at bind time. These associations can be specified using the @code{-V} binder command line switch. -@node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT Bind_Environment g-binenv ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id46}@anchor{328}@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{329} +@node GNAT Branch_Prediction g-brapre ads,GNAT Bounded_Buffers g-boubuf ads,GNAT Bind_Environment g-binenv ads,The GNAT Library +@anchor{gnat_rm/the_gnat_library id46}@anchor{328}@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{329} +@section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads}) + + +@geindex GNAT.Branch_Prediction (g-brapre.ads) + +@geindex Branch Prediction + +Provides routines giving hints to the branch predictor of the code generator. + +@node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT Branch_Prediction g-brapre ads,The GNAT Library +@anchor{gnat_rm/the_gnat_library id47}@anchor{32a}@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{32b} @section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads}) @@ -23801,7 +23861,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 id47}@anchor{32a}@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{32b} +@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{32c}@anchor{gnat_rm/the_gnat_library id48}@anchor{32d} @section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads}) @@ -23814,7 +23874,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{32c}@anchor{gnat_rm/the_gnat_library id48}@anchor{32d} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{32e}@anchor{gnat_rm/the_gnat_library id49}@anchor{32f} @section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads}) @@ -23829,7 +23889,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 id49}@anchor{32e}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{32f} +@anchor{gnat_rm/the_gnat_library id50}@anchor{330}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{331} @section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads}) @@ -23845,7 +23905,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{330}@anchor{gnat_rm/the_gnat_library id50}@anchor{331} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{332}@anchor{gnat_rm/the_gnat_library id51}@anchor{333} @section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads}) @@ -23861,7 +23921,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{332}@anchor{gnat_rm/the_gnat_library id51}@anchor{333} +@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{334}@anchor{gnat_rm/the_gnat_library id52}@anchor{335} @section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads}) @@ -23877,7 +23937,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{334}@anchor{gnat_rm/the_gnat_library id52}@anchor{335} +@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{336}@anchor{gnat_rm/the_gnat_library id53}@anchor{337} @section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads}) @@ -23891,7 +23951,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{336}@anchor{gnat_rm/the_gnat_library id53}@anchor{337} +@anchor{gnat_rm/the_gnat_library id54}@anchor{338}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{339} @section @code{GNAT.Calendar} (@code{g-calend.ads}) @@ -23905,7 +23965,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 id54}@anchor{338}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{339} +@anchor{gnat_rm/the_gnat_library id55}@anchor{33a}@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{33b} @section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads}) @@ -23916,7 +23976,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 id55}@anchor{33a}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{33b} +@anchor{gnat_rm/the_gnat_library id56}@anchor{33c}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{33d} @section @code{GNAT.CRC32} (@code{g-crc32.ads}) @@ -23933,7 +23993,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 id56}@anchor{33c}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{33d} +@anchor{gnat_rm/the_gnat_library id57}@anchor{33e}@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{33f} @section @code{GNAT.Case_Util} (@code{g-casuti.ads}) @@ -23948,7 +24008,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 id57}@anchor{33e}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{33f} +@anchor{gnat_rm/the_gnat_library id58}@anchor{340}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{341} @section @code{GNAT.CGI} (@code{g-cgi.ads}) @@ -23963,7 +24023,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{340}@anchor{gnat_rm/the_gnat_library id58}@anchor{341} +@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{342}@anchor{gnat_rm/the_gnat_library id59}@anchor{343} @section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads}) @@ -23978,7 +24038,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{342}@anchor{gnat_rm/the_gnat_library id59}@anchor{343} +@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{344}@anchor{gnat_rm/the_gnat_library id60}@anchor{345} @section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads}) @@ -23990,7 +24050,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 id60}@anchor{344}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{345} +@anchor{gnat_rm/the_gnat_library id61}@anchor{346}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{347} @section @code{GNAT.Command_Line} (@code{g-comlin.ads}) @@ -24000,10 +24060,10 @@ programs written in Ada. Provides a high level interface to @code{Ada.Command_Line} facilities, including the ability to scan for named switches with optional parameters -and expand file names using wild card notations. +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{346}@anchor{gnat_rm/the_gnat_library id61}@anchor{347} +@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{348}@anchor{gnat_rm/the_gnat_library id62}@anchor{349} @section @code{GNAT.Compiler_Version} (@code{g-comver.ads}) @@ -24021,7 +24081,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{348}@anchor{gnat_rm/the_gnat_library id62}@anchor{349} +@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{34a}@anchor{gnat_rm/the_gnat_library id63}@anchor{34b} @section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads}) @@ -24032,7 +24092,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 id63}@anchor{34a}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{34b} +@anchor{gnat_rm/the_gnat_library id64}@anchor{34c}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{34d} @section @code{GNAT.Current_Exception} (@code{g-curexc.ads}) @@ -24049,7 +24109,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{34c}@anchor{gnat_rm/the_gnat_library id64}@anchor{34d} +@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{34e}@anchor{gnat_rm/the_gnat_library id65}@anchor{34f} @section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads}) @@ -24066,7 +24126,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 id65}@anchor{34e}@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{34f} +@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{350}@anchor{gnat_rm/the_gnat_library id66}@anchor{351} @section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads}) @@ -24079,7 +24139,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{350}@anchor{gnat_rm/the_gnat_library id66}@anchor{351} +@anchor{gnat_rm/the_gnat_library id67}@anchor{352}@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{353} @section @code{GNAT.Decode_String} (@code{g-decstr.ads}) @@ -24103,7 +24163,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{352}@anchor{gnat_rm/the_gnat_library id67}@anchor{353} +@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{354}@anchor{gnat_rm/the_gnat_library id68}@anchor{355} @section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads}) @@ -24124,7 +24184,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{354}@anchor{gnat_rm/the_gnat_library id68}@anchor{355} +@anchor{gnat_rm/the_gnat_library id69}@anchor{356}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{357} @section @code{GNAT.Directory_Operations} (@code{g-dirope.ads}) @@ -24137,7 +24197,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 id69}@anchor{356}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{357} +@anchor{gnat_rm/the_gnat_library id70}@anchor{358}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{359} @section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads}) @@ -24149,7 +24209,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 id70}@anchor{358}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{359} +@anchor{gnat_rm/the_gnat_library id71}@anchor{35a}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{35b} @section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads}) @@ -24167,7 +24227,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{35a}@anchor{gnat_rm/the_gnat_library id71}@anchor{35b} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{35c}@anchor{gnat_rm/the_gnat_library id72}@anchor{35d} @section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads}) @@ -24187,7 +24247,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 id72}@anchor{35c}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{35d} +@anchor{gnat_rm/the_gnat_library id73}@anchor{35e}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{35f} @section @code{GNAT.Encode_String} (@code{g-encstr.ads}) @@ -24209,7 +24269,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{35e}@anchor{gnat_rm/the_gnat_library id73}@anchor{35f} +@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{360}@anchor{gnat_rm/the_gnat_library id74}@anchor{361} @section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads}) @@ -24230,7 +24290,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{360}@anchor{gnat_rm/the_gnat_library id74}@anchor{361} +@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{362}@anchor{gnat_rm/the_gnat_library id75}@anchor{363} @section @code{GNAT.Exception_Actions} (@code{g-excact.ads}) @@ -24243,7 +24303,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{362}@anchor{gnat_rm/the_gnat_library id75}@anchor{363} +@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{364}@anchor{gnat_rm/the_gnat_library id76}@anchor{365} @section @code{GNAT.Exception_Traces} (@code{g-exctra.ads}) @@ -24257,7 +24317,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 id76}@anchor{364}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{365} +@anchor{gnat_rm/the_gnat_library id77}@anchor{366}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{367} @section @code{GNAT.Exceptions} (@code{g-except.ads}) @@ -24278,7 +24338,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{366}@anchor{gnat_rm/the_gnat_library id77}@anchor{367} +@anchor{gnat_rm/the_gnat_library id78}@anchor{368}@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{369} @section @code{GNAT.Expect} (@code{g-expect.ads}) @@ -24294,7 +24354,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 id78}@anchor{368}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{369} +@anchor{gnat_rm/the_gnat_library id79}@anchor{36a}@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{36b} @section @code{GNAT.Expect.TTY} (@code{g-exptty.ads}) @@ -24306,7 +24366,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 id79}@anchor{36a}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{36b} +@anchor{gnat_rm/the_gnat_library id80}@anchor{36c}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{36d} @section @code{GNAT.Float_Control} (@code{g-flocon.ads}) @@ -24320,7 +24380,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 id80}@anchor{36c}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{36d} +@anchor{gnat_rm/the_gnat_library id81}@anchor{36e}@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{36f} @section @code{GNAT.Formatted_String} (@code{g-forstr.ads}) @@ -24335,7 +24395,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{36e}@anchor{gnat_rm/the_gnat_library id81}@anchor{36f} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{370}@anchor{gnat_rm/the_gnat_library id82}@anchor{371} @section @code{GNAT.Heap_Sort} (@code{g-heasor.ads}) @@ -24349,7 +24409,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 id82}@anchor{370}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{371} +@anchor{gnat_rm/the_gnat_library id83}@anchor{372}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{373} @section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads}) @@ -24365,7 +24425,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 id83}@anchor{372}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{373} +@anchor{gnat_rm/the_gnat_library id84}@anchor{374}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{375} @section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads}) @@ -24379,7 +24439,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 id84}@anchor{374}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{375} +@anchor{gnat_rm/the_gnat_library id85}@anchor{376}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{377} @section @code{GNAT.HTable} (@code{g-htable.ads}) @@ -24392,7 +24452,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 id85}@anchor{376}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{377} +@anchor{gnat_rm/the_gnat_library id86}@anchor{378}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{379} @section @code{GNAT.IO} (@code{g-io.ads}) @@ -24408,7 +24468,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{378}@anchor{gnat_rm/the_gnat_library id86}@anchor{379} +@anchor{gnat_rm/the_gnat_library id87}@anchor{37a}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{37b} @section @code{GNAT.IO_Aux} (@code{g-io_aux.ads}) @@ -24422,7 +24482,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 id87}@anchor{37a}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{37b} +@anchor{gnat_rm/the_gnat_library id88}@anchor{37c}@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{37d} @section @code{GNAT.Lock_Files} (@code{g-locfil.ads}) @@ -24436,7 +24496,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 id88}@anchor{37c}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{37d} +@anchor{gnat_rm/the_gnat_library id89}@anchor{37e}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{37f} @section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads}) @@ -24448,7 +24508,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 id89}@anchor{37e}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{37f} +@anchor{gnat_rm/the_gnat_library id90}@anchor{380}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{381} @section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads}) @@ -24460,7 +24520,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 id90}@anchor{380}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{381} +@anchor{gnat_rm/the_gnat_library id91}@anchor{382}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{383} @section @code{GNAT.MD5} (@code{g-md5.ads}) @@ -24473,7 +24533,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 id91}@anchor{382}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{383} +@anchor{gnat_rm/the_gnat_library id92}@anchor{384}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{385} @section @code{GNAT.Memory_Dump} (@code{g-memdum.ads}) @@ -24486,7 +24546,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 id92}@anchor{384}@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{385} +@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{386}@anchor{gnat_rm/the_gnat_library id93}@anchor{387} @section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads}) @@ -24500,7 +24560,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{386}@anchor{gnat_rm/the_gnat_library id93}@anchor{387} +@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{388}@anchor{gnat_rm/the_gnat_library id94}@anchor{389} @section @code{GNAT.OS_Lib} (@code{g-os_lib.ads}) @@ -24516,7 +24576,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{388}@anchor{gnat_rm/the_gnat_library id94}@anchor{389} +@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{38a}@anchor{gnat_rm/the_gnat_library id95}@anchor{38b} @section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads}) @@ -24534,7 +24594,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{38a}@anchor{gnat_rm/the_gnat_library id95}@anchor{38b} +@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{38c}@anchor{gnat_rm/the_gnat_library id96}@anchor{38d} @section @code{GNAT.Random_Numbers} (@code{g-rannum.ads}) @@ -24546,7 +24606,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{255}@anchor{gnat_rm/the_gnat_library id96}@anchor{38c} +@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{255}@anchor{gnat_rm/the_gnat_library id97}@anchor{38e} @section @code{GNAT.Regexp} (@code{g-regexp.ads}) @@ -24562,7 +24622,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{38d}@anchor{gnat_rm/the_gnat_library id97}@anchor{38e} +@anchor{gnat_rm/the_gnat_library id98}@anchor{38f}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{390} @section @code{GNAT.Registry} (@code{g-regist.ads}) @@ -24576,7 +24636,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 id98}@anchor{38f}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{390} +@anchor{gnat_rm/the_gnat_library id99}@anchor{391}@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{392} @section @code{GNAT.Regpat} (@code{g-regpat.ads}) @@ -24591,7 +24651,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 id99}@anchor{391}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{392} +@anchor{gnat_rm/the_gnat_library id100}@anchor{393}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{394} @section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads}) @@ -24605,7 +24665,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 id100}@anchor{393}@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{394} +@anchor{gnat_rm/the_gnat_library id101}@anchor{395}@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{396} @section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads}) @@ -24617,7 +24677,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 id101}@anchor{395}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{396} +@anchor{gnat_rm/the_gnat_library id102}@anchor{397}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{398} @section @code{GNAT.Semaphores} (@code{g-semaph.ads}) @@ -24628,7 +24688,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{397}@anchor{gnat_rm/the_gnat_library id102}@anchor{398} +@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{399}@anchor{gnat_rm/the_gnat_library id103}@anchor{39a} @section @code{GNAT.Serial_Communications} (@code{g-sercom.ads}) @@ -24640,7 +24700,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{399}@anchor{gnat_rm/the_gnat_library id103}@anchor{39a} +@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{39b}@anchor{gnat_rm/the_gnat_library id104}@anchor{39c} @section @code{GNAT.SHA1} (@code{g-sha1.ads}) @@ -24653,7 +24713,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{39b}@anchor{gnat_rm/the_gnat_library id104}@anchor{39c} +@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{39d}@anchor{gnat_rm/the_gnat_library id105}@anchor{39e} @section @code{GNAT.SHA224} (@code{g-sha224.ads}) @@ -24666,7 +24726,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 id105}@anchor{39d}@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{39e} +@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{39f}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a0} @section @code{GNAT.SHA256} (@code{g-sha256.ads}) @@ -24679,7 +24739,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{39f}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a0} +@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{3a1}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a2} @section @code{GNAT.SHA384} (@code{g-sha384.ads}) @@ -24692,7 +24752,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{3a1}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a2} +@anchor{gnat_rm/the_gnat_library id108}@anchor{3a3}@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{3a4} @section @code{GNAT.SHA512} (@code{g-sha512.ads}) @@ -24705,7 +24765,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{3a3}@anchor{gnat_rm/the_gnat_library id108}@anchor{3a4} +@anchor{gnat_rm/the_gnat_library id109}@anchor{3a5}@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{3a6} @section @code{GNAT.Signals} (@code{g-signal.ads}) @@ -24717,7 +24777,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 id109}@anchor{3a5}@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3a6} +@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3a7}@anchor{gnat_rm/the_gnat_library id110}@anchor{3a8} @section @code{GNAT.Sockets} (@code{g-socket.ads}) @@ -24732,7 +24792,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{3a7}@anchor{gnat_rm/the_gnat_library id110}@anchor{3a8} +@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3a9}@anchor{gnat_rm/the_gnat_library id111}@anchor{3aa} @section @code{GNAT.Source_Info} (@code{g-souinf.ads}) @@ -24746,7 +24806,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{3a9}@anchor{gnat_rm/the_gnat_library id111}@anchor{3aa} +@anchor{gnat_rm/the_gnat_library id112}@anchor{3ab}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3ac} @section @code{GNAT.Spelling_Checker} (@code{g-speche.ads}) @@ -24758,7 +24818,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 id112}@anchor{3ab}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3ac} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3ad}@anchor{gnat_rm/the_gnat_library id113}@anchor{3ae} @section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads}) @@ -24771,7 +24831,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 id113}@anchor{3ad}@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3ae} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3af}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b0} @section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads}) @@ -24787,7 +24847,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{3af}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b0} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3b1}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b2} @section @code{GNAT.Spitbol} (@code{g-spitbo.ads}) @@ -24802,7 +24862,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{3b1}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b2} +@anchor{gnat_rm/the_gnat_library id116}@anchor{3b3}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3b4} @section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads}) @@ -24817,7 +24877,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{3b3}@anchor{gnat_rm/the_gnat_library id116}@anchor{3b4} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3b5}@anchor{gnat_rm/the_gnat_library id117}@anchor{3b6} @section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads}) @@ -24834,7 +24894,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 id117}@anchor{3b5}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3b6} +@anchor{gnat_rm/the_gnat_library id118}@anchor{3b7}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3b8} @section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads}) @@ -24851,7 +24911,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 id118}@anchor{3b7}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3b8} +@anchor{gnat_rm/the_gnat_library id119}@anchor{3b9}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3ba} @section @code{GNAT.SSE} (@code{g-sse.ads}) @@ -24863,7 +24923,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{3b9}@anchor{gnat_rm/the_gnat_library id119}@anchor{3ba} +@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3bb}@anchor{gnat_rm/the_gnat_library id120}@anchor{3bc} @section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads}) @@ -24872,7 +24932,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{3bb}@anchor{gnat_rm/the_gnat_library id120}@anchor{3bc} +@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3bd}@anchor{gnat_rm/the_gnat_library id121}@anchor{3be} @section @code{GNAT.String_Hash} (@code{g-strhas.ads}) @@ -24884,7 +24944,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{3bd}@anchor{gnat_rm/the_gnat_library id121}@anchor{3be} +@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3bf}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c0} @section @code{GNAT.Strings} (@code{g-string.ads}) @@ -24894,7 +24954,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{3bf}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c0} +@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3c1}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c2} @section @code{GNAT.String_Split} (@code{g-strspl.ads}) @@ -24908,7 +24968,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{3c1}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c2} +@anchor{gnat_rm/the_gnat_library id124}@anchor{3c3}@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3c4} @section @code{GNAT.Table} (@code{g-table.ads}) @@ -24928,7 +24988,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 id124}@anchor{3c3}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3c4} +@anchor{gnat_rm/the_gnat_library id125}@anchor{3c5}@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3c6} @section @code{GNAT.Task_Lock} (@code{g-tasloc.ads}) @@ -24945,7 +25005,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 id125}@anchor{3c5}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3c6} +@anchor{gnat_rm/the_gnat_library id126}@anchor{3c7}@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3c8} @section @code{GNAT.Time_Stamp} (@code{g-timsta.ads}) @@ -24960,7 +25020,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{3c7}@anchor{gnat_rm/the_gnat_library id126}@anchor{3c8} +@anchor{gnat_rm/the_gnat_library id127}@anchor{3c9}@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3ca} @section @code{GNAT.Threads} (@code{g-thread.ads}) @@ -24977,7 +25037,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 id127}@anchor{3c9}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3ca} +@anchor{gnat_rm/the_gnat_library id128}@anchor{3cb}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3cc} @section @code{GNAT.Traceback} (@code{g-traceb.ads}) @@ -24989,7 +25049,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{3cb}@anchor{gnat_rm/the_gnat_library id128}@anchor{3cc} +@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3cd}@anchor{gnat_rm/the_gnat_library id129}@anchor{3ce} @section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads}) @@ -24998,7 +25058,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 id129}@anchor{3cd}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3ce} +@anchor{gnat_rm/the_gnat_library id130}@anchor{3cf}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3d0} @section @code{GNAT.UTF_32} (@code{g-table.ads}) @@ -25017,7 +25077,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{3cf}@anchor{gnat_rm/the_gnat_library id130}@anchor{3d0} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3d1}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d2} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads}) @@ -25030,7 +25090,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{3d1}@anchor{gnat_rm/the_gnat_library id131}@anchor{3d2} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3d3}@anchor{gnat_rm/the_gnat_library id132}@anchor{3d4} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads}) @@ -25042,7 +25102,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 id132}@anchor{3d3}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3d4} +@anchor{gnat_rm/the_gnat_library id133}@anchor{3d5}@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3d6} @section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads}) @@ -25056,7 +25116,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{3d5}@anchor{gnat_rm/the_gnat_library id133}@anchor{3d6} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3d7}@anchor{gnat_rm/the_gnat_library id134}@anchor{3d8} @section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads}) @@ -25068,7 +25128,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{3d7}@anchor{gnat_rm/the_gnat_library id134}@anchor{3d8} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3d9}@anchor{gnat_rm/the_gnat_library id135}@anchor{3da} @section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads}) @@ -25082,7 +25142,7 @@ to the resulting slices. This package is instantiated from @code{GNAT.Array_Split}. @node Interfaces C Extensions i-cexten ads,Interfaces C Streams i-cstrea ads,GNAT Wide_Wide_String_Split g-zistsp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3d9}@anchor{gnat_rm/the_gnat_library id135}@anchor{3da} +@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3db}@anchor{gnat_rm/the_gnat_library id136}@anchor{3dc} @section @code{Interfaces.C.Extensions} (@code{i-cexten.ads}) @@ -25093,7 +25153,7 @@ for use with either manually or automatically generated bindings to C libraries. @node Interfaces C Streams i-cstrea ads,Interfaces Packed_Decimal i-pacdec ads,Interfaces C Extensions i-cexten ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3db}@anchor{gnat_rm/the_gnat_library id136}@anchor{3dc} +@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3dd}@anchor{gnat_rm/the_gnat_library id137}@anchor{3de} @section @code{Interfaces.C.Streams} (@code{i-cstrea.ads}) @@ -25106,7 +25166,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 interfaces-packed-decimal-i-pacdec-ads}@anchor{3dd}@anchor{gnat_rm/the_gnat_library id137}@anchor{3de} +@anchor{gnat_rm/the_gnat_library id138}@anchor{3df}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3e0} @section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads}) @@ -25121,7 +25181,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 id138}@anchor{3df}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e0} +@anchor{gnat_rm/the_gnat_library id139}@anchor{3e1}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3e2} @section @code{Interfaces.VxWorks} (@code{i-vxwork.ads}) @@ -25137,7 +25197,7 @@ In particular, it interfaces with the VxWorks hardware interrupt facilities. @node Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces VxWorks i-vxwork ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3e1}@anchor{gnat_rm/the_gnat_library id139}@anchor{3e2} +@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3e3}@anchor{gnat_rm/the_gnat_library id140}@anchor{3e4} @section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads}) @@ -25153,7 +25213,7 @@ intConnect() with a custom routine for installing interrupt handlers. @node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks Int_Connection i-vxinco ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3e3}@anchor{gnat_rm/the_gnat_library id140}@anchor{3e4} +@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3e5}@anchor{gnat_rm/the_gnat_library id141}@anchor{3e6} @section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads}) @@ -25176,7 +25236,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 id141}@anchor{3e5}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3e6} +@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3e7}@anchor{gnat_rm/the_gnat_library id142}@anchor{3e8} @section @code{System.Address_Image} (@code{s-addima.ads}) @@ -25192,7 +25252,7 @@ function that gives an (implementation dependent) string which identifies an address. @node System Assertions s-assert ads,System Atomic_Counters s-atocou ads,System Address_Image s-addima ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3e7}@anchor{gnat_rm/the_gnat_library id142}@anchor{3e8} +@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3e9}@anchor{gnat_rm/the_gnat_library id143}@anchor{3ea} @section @code{System.Assertions} (@code{s-assert.ads}) @@ -25208,7 +25268,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 id143}@anchor{3e9}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3ea} +@anchor{gnat_rm/the_gnat_library id144}@anchor{3eb}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3ec} @section @code{System.Atomic_Counters} (@code{s-atocou.ads}) @@ -25222,7 +25282,7 @@ on most targets, including all Alpha, ia64, PowerPC, SPARC V9, x86, and x86_64 platforms. @node System Memory s-memory ads,System Multiprocessors s-multip ads,System Atomic_Counters s-atocou ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3eb}@anchor{gnat_rm/the_gnat_library id144}@anchor{3ec} +@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3ed}@anchor{gnat_rm/the_gnat_library id145}@anchor{3ee} @section @code{System.Memory} (@code{s-memory.ads}) @@ -25240,7 +25300,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 id145}@anchor{3ed}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3ee} +@anchor{gnat_rm/the_gnat_library id146}@anchor{3ef}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3f0} @section @code{System.Multiprocessors} (@code{s-multip.ads}) @@ -25253,7 +25313,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is technically an implementation-defined addition). @node System Multiprocessors Dispatching_Domains s-mudido ads,System Partition_Interface s-parint ads,System Multiprocessors s-multip ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3ef}@anchor{gnat_rm/the_gnat_library id146}@anchor{3f0} +@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3f1}@anchor{gnat_rm/the_gnat_library id147}@anchor{3f2} @section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads}) @@ -25266,7 +25326,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 id147}@anchor{3f1}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f2} +@anchor{gnat_rm/the_gnat_library id148}@anchor{3f3}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3f4} @section @code{System.Partition_Interface} (@code{s-parint.ads}) @@ -25279,7 +25339,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 id148}@anchor{3f3}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3f4} +@anchor{gnat_rm/the_gnat_library id149}@anchor{3f5}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3f6} @section @code{System.Pool_Global} (@code{s-pooglo.ads}) @@ -25296,7 +25356,7 @@ declared. It uses malloc/free to allocate/free and does not attempt to do any automatic reclamation. @node System Pool_Local s-pooloc ads,System Restrictions s-restri ads,System Pool_Global s-pooglo ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3f5}@anchor{gnat_rm/the_gnat_library id149}@anchor{3f6} +@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3f7}@anchor{gnat_rm/the_gnat_library id150}@anchor{3f8} @section @code{System.Pool_Local} (@code{s-pooloc.ads}) @@ -25313,7 +25373,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 id150}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3f8} +@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3f9}@anchor{gnat_rm/the_gnat_library id151}@anchor{3fa} @section @code{System.Restrictions} (@code{s-restri.ads}) @@ -25329,7 +25389,7 @@ compiler determined information on which restrictions are violated by one or more packages in the partition. @node System Rident s-rident ads,System Strings Stream_Ops s-ststop ads,System Restrictions s-restri ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3f9}@anchor{gnat_rm/the_gnat_library id151}@anchor{3fa} +@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3fb}@anchor{gnat_rm/the_gnat_library id152}@anchor{3fc} @section @code{System.Rident} (@code{s-rident.ads}) @@ -25345,7 +25405,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 id152}@anchor{3fb}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3fc} +@anchor{gnat_rm/the_gnat_library id153}@anchor{3fd}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3fe} @section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads}) @@ -25361,7 +25421,7 @@ stream attributes are applied to string types, but the subprograms in this package can be used directly by application programs. @node System Unsigned_Types s-unstyp ads,System Wch_Cnv s-wchcnv ads,System Strings Stream_Ops s-ststop ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3fd}@anchor{gnat_rm/the_gnat_library id153}@anchor{3fe} +@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3ff}@anchor{gnat_rm/the_gnat_library id154}@anchor{400} @section @code{System.Unsigned_Types} (@code{s-unstyp.ads}) @@ -25374,7 +25434,7 @@ also contains some related definitions for other specialized types used by the compiler in connection with packed array types. @node System Wch_Cnv s-wchcnv ads,System Wch_Con s-wchcon ads,System Unsigned_Types s-unstyp ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3ff}@anchor{gnat_rm/the_gnat_library id154}@anchor{400} +@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{401}@anchor{gnat_rm/the_gnat_library id155}@anchor{402} @section @code{System.Wch_Cnv} (@code{s-wchcnv.ads}) @@ -25395,7 +25455,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 system-wch-con-s-wchcon-ads}@anchor{401}@anchor{gnat_rm/the_gnat_library id155}@anchor{402} +@anchor{gnat_rm/the_gnat_library id156}@anchor{403}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{404} @section @code{System.Wch_Con} (@code{s-wchcon.ads}) @@ -25407,7 +25467,7 @@ in ordinary strings. These definitions are used by the package @code{System.Wch_Cnv}. @node Interfacing to Other Languages,Specialized Needs Annexes,The GNAT Library,Top -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{403}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{404} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{405}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{406} @chapter Interfacing to Other Languages @@ -25425,7 +25485,7 @@ provided. @end menu @node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{405}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{406} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{407}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{408} @section Interfacing to C @@ -25565,7 +25625,7 @@ of the length corresponding to the @code{type'Size} value in Ada. @end itemize @node Interfacing to C++,Interfacing to COBOL,Interfacing to C,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{407}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{49} +@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{409}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{49} @section Interfacing to C++ @@ -25622,7 +25682,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{408}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{409} +@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{40a}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{40b} @section Interfacing to COBOL @@ -25630,7 +25690,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{40a}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{40b} +@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{40c}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{40d} @section Interfacing to Fortran @@ -25640,7 +25700,7 @@ multi-dimensional array causes the array to be stored in column-major order as required for convenient interface to Fortran. @node Interfacing to non-GNAT Ada code,,Interfacing to Fortran,Interfacing to Other Languages -@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{40c}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{40d} +@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{40e}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{40f} @section Interfacing to non-GNAT Ada code @@ -25664,7 +25724,7 @@ values or simple record types without variants, or simple array types with fixed bounds. @node Specialized Needs Annexes,Implementation of Specific Ada Features,Interfacing to Other Languages,Top -@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{40e}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{40f} +@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{410}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{411} @chapter Specialized Needs Annexes @@ -25705,7 +25765,7 @@ in Ada 2005) is fully implemented. @end table @node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top -@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{410}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{411} +@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{412}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{413} @chapter Implementation of Specific Ada Features @@ -25723,7 +25783,7 @@ facilities. @end menu @node Machine Code Insertions,GNAT Implementation of Tasking,,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{168}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{412} +@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{168}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{414} @section Machine Code Insertions @@ -25891,7 +25951,7 @@ according to normal visibility rules. In particular if there is no qualification is required. @node GNAT Implementation of Tasking,GNAT Implementation of Shared Passive Packages,Machine Code Insertions,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{413}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{414} +@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{415}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{416} @section GNAT Implementation of Tasking @@ -25907,7 +25967,7 @@ to compliance with the Real-Time Systems Annex. @end menu @node Mapping Ada Tasks onto the Underlying Kernel Threads,Ensuring Compliance with the Real-Time Annex,,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{415}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{416} +@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{417}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{418} @subsection Mapping Ada Tasks onto the Underlying Kernel Threads @@ -25976,7 +26036,7 @@ support this functionality when the parent contains more than one task. @geindex Forking a new process @node Ensuring Compliance with the Real-Time Annex,Support for Locking Policies,Mapping Ada Tasks onto the Underlying Kernel Threads,GNAT Implementation of Tasking -@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{417}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{418} +@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{419}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{41a} @subsection Ensuring Compliance with the Real-Time Annex @@ -26027,7 +26087,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{419} +@anchor{gnat_rm/implementation_of_specific_ada_features support-for-locking-policies}@anchor{41b} @subsection Support for Locking Policies @@ -26061,7 +26121,7 @@ then ceiling locking is used. Otherwise, the @code{Ceiling_Locking} policy is ignored. @node GNAT Implementation of Shared Passive Packages,Code Generation for Array Aggregates,GNAT Implementation of Tasking,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{41a}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{41b} +@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{41c}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{41d} @section GNAT Implementation of Shared Passive Packages @@ -26162,7 +26222,7 @@ GNAT supports shared passive packages on all platforms except for OpenVMS. @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{41c}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{41d} +@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{41e}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{41f} @section Code Generation for Array Aggregates @@ -26193,7 +26253,7 @@ component values and static subtypes also lead to simpler code. @end menu @node Static constant aggregates with static bounds,Constant aggregates with unconstrained nominal types,,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{41e}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{41f} +@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{420}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{421} @subsection Static constant aggregates with static bounds @@ -26240,7 +26300,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{420}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{421} +@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{422}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{423} @subsection Constant aggregates with unconstrained nominal types @@ -26255,7 +26315,7 @@ Cr_Unc : constant One_Unc := (12,24,36); @end example @node Aggregates with static bounds,Aggregates with nonstatic bounds,Constant aggregates with unconstrained nominal types,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{422}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{423} +@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{424}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{425} @subsection Aggregates with static bounds @@ -26283,7 +26343,7 @@ end loop; @end example @node Aggregates with nonstatic bounds,Aggregates in assignment statements,Aggregates with static bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{424}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{425} +@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{426}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{427} @subsection Aggregates with nonstatic bounds @@ -26294,7 +26354,7 @@ have to be applied to sub-arrays individually, if they do not have statically compatible subtypes. @node Aggregates in assignment statements,,Aggregates with nonstatic bounds,Code Generation for Array Aggregates -@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{426}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{427} +@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{428}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{429} @subsection Aggregates in assignment statements @@ -26336,7 +26396,7 @@ a temporary (created either by the front-end or the code generator) and then that temporary will be copied onto the target. @node The Size of Discriminated Records with Default Discriminants,Strict Conformance to the Ada Reference Manual,Code Generation for Array Aggregates,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{428}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{429} +@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{42a}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{42b} @section The Size of Discriminated Records with Default Discriminants @@ -26416,7 +26476,7 @@ say) must be consistent, so it is imperative that the object, once created, remain invariant. @node Strict Conformance to the Ada Reference Manual,,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features -@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{42a}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{42b} +@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{42c}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{42d} @section Strict Conformance to the Ada Reference Manual @@ -26443,7 +26503,7 @@ behavior (although at the cost of a significant performance penalty), so infinite and NaN values are properly generated. @node Implementation of Ada 2012 Features,Obsolescent Features,Implementation of Specific Ada Features,Top -@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{42c}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{42d} +@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{42e}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{42f} @chapter Implementation of Ada 2012 Features @@ -28609,7 +28669,7 @@ RM References: H.04 (8/1) @end itemize @node Obsolescent Features,Compatibility and Porting Guide,Implementation of Ada 2012 Features,Top -@anchor{gnat_rm/obsolescent_features id1}@anchor{42e}@anchor{gnat_rm/obsolescent_features doc}@anchor{42f}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15} +@anchor{gnat_rm/obsolescent_features id1}@anchor{430}@anchor{gnat_rm/obsolescent_features doc}@anchor{431}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15} @chapter Obsolescent Features @@ -28628,7 +28688,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{430}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{431} +@anchor{gnat_rm/obsolescent_features id2}@anchor{432}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{433} @section pragma No_Run_Time @@ -28641,7 +28701,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{432}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{433} +@anchor{gnat_rm/obsolescent_features id3}@anchor{434}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{435} @section pragma Ravenscar @@ -28650,7 +28710,7 @@ The pragma @code{Ravenscar} has exactly the same effect as pragma is part of the new Ada 2005 standard. @node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features -@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{434}@anchor{gnat_rm/obsolescent_features id4}@anchor{435} +@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{436}@anchor{gnat_rm/obsolescent_features id4}@anchor{437} @section pragma Restricted_Run_Time @@ -28660,7 +28720,7 @@ preferred since the Ada 2005 pragma @code{Profile} is intended for this kind of implementation dependent addition. @node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features -@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{436}@anchor{gnat_rm/obsolescent_features id5}@anchor{437} +@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{438}@anchor{gnat_rm/obsolescent_features id5}@anchor{439} @section pragma Task_Info @@ -28686,7 +28746,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{438}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{439} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43a}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{43b} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -28696,7 +28756,7 @@ to support the @code{Task_Info} pragma. The predefined Ada package standard replacement for GNAT's @code{Task_Info} functionality. @node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top -@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{43a}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{43b} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{43c}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{43d} @chapter Compatibility and Porting Guide @@ -28718,7 +28778,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{43c}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{43d} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{43e}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{43f} @section Writing Portable Fixed-Point Declarations @@ -28840,7 +28900,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{43e}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{43f} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{440}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{441} @section Compatibility with Ada 83 @@ -28868,7 +28928,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{440}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{441} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{442}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{443} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -28968,7 +29028,7 @@ the fix is usually simply to add the @code{(<>)} to the generic declaration. @end itemize @node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{442}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{443} +@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{444}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{445} @subsection More deterministic semantics @@ -28996,7 +29056,7 @@ which open select branches are executed. @end itemize @node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{444}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{445} +@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{446}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{447} @subsection Changed semantics @@ -29038,7 +29098,7 @@ covers only the restricted range. @end itemize @node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83 -@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{446}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{447} +@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{448}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{449} @subsection Other language compatibility issues @@ -29071,7 +29131,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{448}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{449} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{44a}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{44b} @section Compatibility between Ada 95 and Ada 2005 @@ -29143,7 +29203,7 @@ can declare a function returning a value from an anonymous access type. @end itemize @node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{44a}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{44b} +@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{44c}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{44d} @section Implementation-dependent characteristics @@ -29166,7 +29226,7 @@ transition from certain Ada 83 compilers. @end menu @node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{44c}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{44d} +@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{44e}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{44f} @subsection Implementation-defined pragmas @@ -29188,7 +29248,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{44e}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{44f} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{450}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{451} @subsection Implementation-defined attributes @@ -29202,7 +29262,7 @@ Ada 83, GNAT supplies the attributes @code{Bit}, @code{Machine_Size} and @code{Type_Class}. @node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{450}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{451} +@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{452}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{453} @subsection Libraries @@ -29231,7 +29291,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{452}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{453} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{454}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{455} @subsection Elaboration order @@ -29267,7 +29327,7 @@ pragmas either globally (as an effect of the @emph{-gnatE} switch) or locally @end itemize @node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics -@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{454}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{455} +@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{456}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{457} @subsection Target-specific aspects @@ -29280,10 +29340,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{456,,Representation Clauses}. +GNAT's approach to these issues is described in @ref{458,,Representation Clauses}. @node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{457}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{458} +@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{459}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45a} @section Compatibility with Other Ada Systems @@ -29326,7 +29386,7 @@ far beyond this minimal set, as described in the next section. @end itemize @node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide -@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{456}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{459} +@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{458}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{45b} @section Representation Clauses @@ -29419,7 +29479,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{45a}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{45b} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{45c}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{45d} @section Compatibility with HP Ada 83 @@ -29449,7 +29509,7 @@ extension of package System. @end itemize @node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{45c}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{45d} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{45e}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{45f} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 7371a76..e3d6a3a 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -463,6 +463,7 @@ Microsoft Windows Topics * CONSOLE and WINDOWS subsystems:: * Temporary Files:: * Disabling Command Line Argument Expansion:: +* Windows Socket Timeouts:: * Mixed-Language Programming on Windows:: * Windows Specific Add-Ons:: @@ -532,15 +533,11 @@ Elaboration Order Handling in GNAT * Checking the Elaboration Order:: * Controlling the Elaboration Order in Ada:: * Controlling the Elaboration Order in GNAT:: -* Common Elaboration-model Traits:: -* Dynamic Elaboration Model in GNAT:: -* Static Elaboration Model in GNAT:: -* SPARK Elaboration Model in GNAT:: -* Legacy Elaboration Model in GNAT:: * Mixing Elaboration Models:: +* ABE Diagnostics:: +* SPARK Diagnostics:: * Elaboration Circularities:: * Resolving Elaboration Circularities:: -* Resolving Task Issues:: * Elaboration-related Compiler Switches:: * Summary of Procedures for Elaboration Control:: * Inspecting the Chosen Elaboration Order:: @@ -6645,8 +6642,9 @@ identifiers with identical name (except casing) will generate compilation errors (e.g. @code{shm_get} vs @code{SHM_GET}). @end itemize -The code generated is using the Ada 2005 syntax, which makes it -easier to interface with other languages than previous versions of Ada. +The code is generated using Ada 2012 syntax, which makes it easier to interface +with other languages. In most cases you can still use the generated binding +even if your code is compiled using earlier versions of Ada (e.g. @code{-gnat95}). @menu * Running the Binding Generator:: @@ -6667,7 +6665,7 @@ header files needed by these files transitively. For example: @example $ g++ -c -fdump-ada-spec -C /usr/include/time.h -$ gcc -c -gnat05 *.ads +$ gcc -c *.ads @end example will generate, under GNU/Linux, the following files: @code{time_h.ads}, @@ -9583,7 +9581,8 @@ checking options to be controlled from the command line. @item @code{-gnatE} -Full dynamic elaboration checks. +Dynamic elaboration checking mode enabled. For further details see +@ref{f,,Elaboration Order Handling in GNAT}. @end table @geindex -gnatf (gcc) @@ -9649,8 +9648,9 @@ Output usage information. The output is written to @code{stdout}. @item @code{-gnatH} -Legacy elaboration-checking mode enabled. When this switch is in effect, the -pre-18.x access-before-elaboration model becomes the de facto model. +Legacy elaboration-checking mode enabled. When this switch is in effect, +the pre-18.x access-before-elaboration model becomes the de facto model. +For further details see @ref{f,,Elaboration Order Handling in GNAT}. @end table @geindex -gnati (gcc) @@ -9747,7 +9747,8 @@ Select statements Synchronous task suspension @end itemize -and does not emit compile-time diagnostics or run-time checks. +and does not emit compile-time diagnostics or run-time checks. For further +details see @ref{f,,Elaboration Order Handling in GNAT}. @end table @geindex -gnatk (gcc) @@ -11039,6 +11040,37 @@ This switch suppresses warnings for assertions where the compiler can tell at compile time that the assertion will fail. @end table +@geindex -gnatw_a + + +@table @asis + +@item @code{-gnatw_a} + +@emph{Activate warnings on anonymous allocators.} + +@geindex Anonymous allocators + +This switch activates warnings for allocators of anonymous access types, +which can involve run-time accessibility checks and lead to unexpected +accessibility violations. For more details on the rules involved, see +RM 3.10.2 (14). +@end table + +@geindex -gnatw_A + + +@table @asis + +@item @code{-gnatw_A} + +@emph{Supress warnings on anonymous allocators.} + +@geindex Anonymous allocators + +This switch suppresses warnings for anonymous access type allocators. +@end table + @geindex -gnatwb (gcc) @@ -14283,7 +14315,7 @@ $ gcc -c -gnats x.adb compiles file @code{x.adb} in syntax-check-only mode. You can check a series of files in a single command -, and can use wild cards to specify such a group of files. +, and can use wildcards to specify such a group of files. Note that you must specify the @code{-c} (compile only) flag in addition to the @code{-gnats} flag. @@ -15745,7 +15777,8 @@ Currently the same as @code{-Ea}. @item @code{-f@emph{elab-order}} -Force elaboration order. +Force elaboration order. For further details see @ref{120,,Elaboration Control} +and @ref{f,,Elaboration Order Handling in GNAT}. @end table @geindex -F (gnatbind) @@ -15772,22 +15805,41 @@ flag checks are generated. @item @code{-h} Output usage (help) information. +@end table + +@geindex -H (gnatbind) + + +@table @asis + +@item @code{-H} + +Legacy elaboration order model enabled. For further details see +@ref{f,,Elaboration Order Handling in GNAT}. +@end table @geindex -H32 (gnatbind) + +@table @asis + @item @code{-H32} Use 32-bit allocations for @code{__gnat_malloc} (and thus for access types). -For further details see @ref{120,,Dynamic Allocation Control}. +For further details see @ref{121,,Dynamic Allocation Control}. +@end table @geindex -H64 (gnatbind) @geindex __gnat_malloc + +@table @asis + @item @code{-H64} Use 64-bit allocations for @code{__gnat_malloc} (and thus for access types). -For further details see @ref{120,,Dynamic Allocation Control}. +For further details see @ref{121,,Dynamic Allocation Control}. @geindex -I (gnatbind) @@ -15840,6 +15892,25 @@ limit, then a message is output and the bind is abandoned. A value of zero means that no limit is enforced. The equal sign is optional. +@geindex -minimal (gnatbind) + +@item @code{-minimal} + +Generate a binder file suitable for space-constrained applications. When +active, binder-generated objects not required for program operation are no +longer generated. @strong{Warning:} this option comes with the following +limitations: + + +@itemize * + +@item +Debugging will not work; + +@item +Programs using GNAT.Compiler_Version will not link. +@end itemize + @geindex -n (gnatbind) @item @code{-n} @@ -16017,7 +16088,7 @@ Enable dynamic stack usage, with @code{n} results stored and displayed at program termination. A result is generated when a task terminates. Results that can't be stored are displayed on the fly, at task termination. This option is currently not supported on Itanium -platforms. (See @ref{121,,Dynamic Stack Usage Analysis} for details.) +platforms. (See @ref{122,,Dynamic Stack Usage Analysis} for details.) @geindex -v (gnatbind) @@ -16086,7 +16157,7 @@ no arguments. @end menu @node Consistency-Checking Modes,Binder Error Message Control,,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{122}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{123} +@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{123}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{124} @subsubsection Consistency-Checking Modes @@ -16140,7 +16211,7 @@ case the checking against sources has already been performed by @end table @node Binder Error Message Control,Elaboration Control,Consistency-Checking Modes,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{124}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{125} +@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{125}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{126} @subsubsection Binder Error Message Control @@ -16250,12 +16321,12 @@ with extreme care. @end table @node Elaboration Control,Output Control,Binder Error Message Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{126}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{127} +@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{127}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{120} @subsubsection Elaboration Control The following switches provide additional control over the elaboration -order. For full details see @ref{f,,Elaboration Order Handling in GNAT}. +order. For further details see @ref{f,,Elaboration Order Handling in GNAT}. @geindex -f (gnatbind) @@ -16300,30 +16371,38 @@ above forced elaboration order file. Blank lines and Ada-style comments are ignored. Unit names that do not exist in the program are ignored. Units in the GNAT predefined library are also ignored. +@end table @geindex -p (gnatbind) + +@table @asis + @item @code{-p} -Normally the binder attempts to choose an elaboration order that is -likely to minimize the likelihood of an elaboration order error resulting -in raising a @code{Program_Error} exception. This switch reverses the -action of the binder, and requests that it deliberately choose an order -that is likely to maximize the likelihood of an elaboration error. -This is useful in ensuring portability and avoiding dependence on -accidental fortuitous elaboration ordering. +Pessimistic elaboration order -Normally it only makes sense to use the @code{-p} -switch if dynamic +This switch is only applicable to the pre-20.x legacy elaboration models. +The post-20.x elaboration model uses a more informed approach of ordering +the units. + +Normally the binder attempts to choose an elaboration order that is likely to +minimize the likelihood of an elaboration order error resulting in raising a +@code{Program_Error} exception. This switch reverses the action of the binder, +and requests that it deliberately choose an order that is likely to maximize +the likelihood of an elaboration error. This is useful in ensuring +portability and avoiding dependence on accidental fortuitous elaboration +ordering. + +Normally it only makes sense to use the @code{-p} switch if dynamic elaboration checking is used (@code{-gnatE} switch used for compilation). This is because in the default static elaboration mode, all necessary @code{Elaborate} and @code{Elaborate_All} pragmas are implicitly inserted. -These implicit pragmas are still respected by the binder in -@code{-p} mode, so a -safe elaboration order is assured. +These implicit pragmas are still respected by the binder in @code{-p} +mode, so a safe elaboration order is assured. -Note that @code{-p} is not intended for -production use; it is more for debugging/experimental use. +Note that @code{-p} is not intended for production use; it is more for +debugging/experimental use. @end table @node Output Control,Dynamic Allocation Control,Elaboration Control,Switches for gnatbind @@ -16408,7 +16487,7 @@ be used to improve code generation in some cases. @end table @node Dynamic Allocation Control,Binding with Non-Ada Main Programs,Output Control,Switches for gnatbind -@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{120}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{12a} +@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{121}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{12a} @subsubsection Dynamic Allocation Control @@ -18964,7 +19043,7 @@ If you do not specify an extension, it will default to @code{htm}. @item @code{f} By default, gnathtml will generate html links only for global entities -('with'ed units, global variables and types,...). If you specify +('with'ed units, global variables and types,...). If you specify @code{-f} on the command line, then links will be generated for local entities too. @end table @@ -23167,7 +23246,7 @@ subprogram whose stack usage might be larger than the specified amount of bytes. The wording is in keeping with the qualifier documented above. @node Dynamic Stack Usage Analysis,,Static Stack Usage Analysis,Stack Related Facilities -@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{121}@anchor{gnat_ugn/gnat_and_program_execution id60}@anchor{1c6} +@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{122}@anchor{gnat_ugn/gnat_and_program_execution id60}@anchor{1c6} @subsection Dynamic Stack Usage Analysis @@ -23900,15 +23979,13 @@ This section describes topics that are specific to the Microsoft Windows platforms. - - - @menu * Using GNAT on Windows:: * Using a network installation of GNAT:: * CONSOLE and WINDOWS subsystems:: * Temporary Files:: * Disabling Command Line Argument Expansion:: +* Windows Socket Timeouts:: * Mixed-Language Programming on Windows:: * Windows Specific Add-Ons:: @@ -24082,7 +24159,7 @@ file will be created. This is particularly useful in networked environments where you may not have write access to some directories. -@node Disabling Command Line Argument Expansion,Mixed-Language Programming on Windows,Temporary Files,Microsoft Windows Topics +@node Disabling Command Line Argument Expansion,Windows Socket Timeouts,Temporary Files,Microsoft Windows Topics @anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1e1} @subsection Disabling Command Line Argument Expansion @@ -24153,8 +24230,54 @@ and: Ada.Command_Line.Argument (1) -> "'*.txt'" @end example -@node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Disabling Command Line Argument Expansion,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information id13}@anchor{1e2}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1e3} +@node Windows Socket Timeouts,Mixed-Language Programming on Windows,Disabling Command Line Argument Expansion,Microsoft Windows Topics +@anchor{gnat_ugn/platform_specific_information windows-socket-timeouts}@anchor{1e2} +@subsection Windows Socket Timeouts + + +Microsoft Windows desktops older than @code{8.0} and Microsoft Windows Servers +older than @code{2019} set a socket timeout 500 milliseconds longer than the value +set by setsockopt with @code{SO_RCVTIMEO} and @code{SO_SNDTIMEO} options. The GNAT +runtime makes a correction for the difference in the corresponding Windows +versions. For Windows Server starting with version @code{2019}, the user must +provide a manifest file for the GNAT runtime to be able to recognize that +the Windows version does not need the timeout correction. The manifest file +should be located in the same directory as the executable file, and its file +name must match the executable name suffixed by @code{.manifest}. For example, +if the executable name is @code{sock_wto.exe}, then the manifest file name +has to be @code{sock_wto.exe.manifest}. The manifest file must contain at +least the following data: + +@example +<?xml version="1.0" encoding="UTF-8" standalone="yes"?> +<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1"> +<application> + <!-- Windows Vista --> + <supportedOS Id="@{e2011457-1546-43c5-a5fe-008deee3d3f0@}"/> + <!-- Windows 7 --> + <supportedOS Id="@{35138b9a-5d96-4fbd-8e2d-a2440225f93a@}"/> + <!-- Windows 8 --> + <supportedOS Id="@{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38@}"/> + <!-- Windows 8.1 --> + <supportedOS Id="@{1f676c76-80e1-4239-95bb-83d0f6d0da78@}"/> + <!-- Windows 10 --> + <supportedOS Id="@{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a@}"/> +</application> +</compatibility> +</assembly> +@end example + +Without the manifest file, the socket timeout is going to be overcorrected on +these Windows Server versions and the actual time is going to be 500 +milliseconds shorter than what was set with GNAT.Sockets.Set_Socket_Option. +Note that on Microsoft Windows versions where correction is necessary, there +is no way to set a socket timeout shorter than 500 ms. If a socket timeout +shorter than 500 ms is needed on these Windows versions, a call to +Check_Selector should be added before any socket read or write operations. + +@node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Windows Socket Timeouts,Microsoft Windows Topics +@anchor{gnat_ugn/platform_specific_information id13}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1e4} @subsection Mixed-Language Programming on Windows @@ -24176,12 +24299,12 @@ to use the Microsoft tools for your C++ code, you have two choices: Encapsulate your C++ code in a DLL to be linked with your Ada application. In this case, use the Microsoft or whatever environment to build the DLL and use GNAT to build your executable -(@ref{1e4,,Using DLLs with GNAT}). +(@ref{1e5,,Using DLLs with GNAT}). @item Or you can encapsulate your Ada code in a DLL to be linked with the other part of your application. In this case, use GNAT to build the DLL -(@ref{1e5,,Building DLLs with GNAT Project files}) and use the Microsoft +(@ref{1e6,,Building DLLs with GNAT Project files}) and use the Microsoft or whatever environment to build your executable. @end itemize @@ -24238,7 +24361,7 @@ native SEH support is used. @end menu @node Windows Calling Conventions,Introduction to Dynamic Link Libraries DLLs,,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1e6}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1e7} +@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1e7}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1e8} @subsubsection Windows Calling Conventions @@ -24283,7 +24406,7 @@ are available for Windows: @end menu @node C Calling Convention,Stdcall Calling Convention,,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1e9} +@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1e9}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1ea} @subsubsection @code{C} Calling Convention @@ -24325,10 +24448,10 @@ is missing, as in the above example, this parameter is set to be the When importing a variable defined in C, you should always use the @code{C} calling convention unless the object containing the variable is part of a DLL (in which case you should use the @code{Stdcall} calling -convention, @ref{1ea,,Stdcall Calling Convention}). +convention, @ref{1eb,,Stdcall Calling Convention}). @node Stdcall Calling Convention,Win32 Calling Convention,C Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1ea}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1eb} +@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1eb}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1ec} @subsubsection @code{Stdcall} Calling Convention @@ -24425,7 +24548,7 @@ Note that to ease building cross-platform bindings this convention will be handled as a @code{C} calling convention on non-Windows platforms. @node Win32 Calling Convention,DLL Calling Convention,Stdcall Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1ec}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1ed} +@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1ed}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1ee} @subsubsection @code{Win32} Calling Convention @@ -24433,7 +24556,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node DLL Calling Convention,,Win32 Calling Convention,Windows Calling Conventions -@anchor{gnat_ugn/platform_specific_information id18}@anchor{1ee}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1ef} +@anchor{gnat_ugn/platform_specific_information id18}@anchor{1ef}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1f0} @subsubsection @code{DLL} Calling Convention @@ -24441,7 +24564,7 @@ This convention, which is GNAT-specific is fully equivalent to the @code{Stdcall} calling convention described above. @node Introduction to Dynamic Link Libraries DLLs,Using DLLs with GNAT,Windows Calling Conventions,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id19}@anchor{1f0}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1f1} +@anchor{gnat_ugn/platform_specific_information id19}@anchor{1f1}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1f2} @subsubsection Introduction to Dynamic Link Libraries (DLLs) @@ -24525,10 +24648,10 @@ As a side note, an interesting difference between Microsoft DLLs and Unix shared libraries, is the fact that on most Unix systems all public routines are exported by default in a Unix shared library, while under Windows it is possible (but not required) to list exported routines in -a definition file (see @ref{1f2,,The Definition File}). +a definition file (see @ref{1f3,,The Definition File}). @node Using DLLs with GNAT,Building DLLs with GNAT Project files,Introduction to Dynamic Link Libraries DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id20}@anchor{1f3}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1e4} +@anchor{gnat_ugn/platform_specific_information id20}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1e5} @subsubsection Using DLLs with GNAT @@ -24619,7 +24742,7 @@ example a fictitious DLL called @code{API.dll}. @end menu @node Creating an Ada Spec for the DLL Services,Creating an Import Library,,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information id21}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1f5} +@anchor{gnat_ugn/platform_specific_information id21}@anchor{1f5}@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1f6} @subsubsection Creating an Ada Spec for the DLL Services @@ -24659,7 +24782,7 @@ end API; @end quotation @node Creating an Import Library,,Creating an Ada Spec for the DLL Services,Using DLLs with GNAT -@anchor{gnat_ugn/platform_specific_information id22}@anchor{1f6}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1f7} +@anchor{gnat_ugn/platform_specific_information id22}@anchor{1f7}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1f8} @subsubsection Creating an Import Library @@ -24673,7 +24796,7 @@ as in this case it is possible to link directly against the DLL. Otherwise read on. @geindex Definition file -@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1f2} +@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1f3} @subsubheading The Definition File @@ -24721,17 +24844,17 @@ EXPORTS @end table Note that you must specify the correct suffix (@code{@@@emph{nn}}) -(see @ref{1e6,,Windows Calling Conventions}) for a Stdcall +(see @ref{1e7,,Windows Calling Conventions}) for a Stdcall calling convention function in the exported symbols list. There can actually be other sections in a definition file, but these sections are not relevant to the discussion at hand. -@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1f8} +@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1f9} @subsubheading Creating a Definition File Automatically You can automatically create the definition file @code{API.def} -(see @ref{1f2,,The Definition File}) from a DLL. +(see @ref{1f3,,The Definition File}) from a DLL. For that use the @code{dlltool} program as follows: @quotation @@ -24741,7 +24864,7 @@ $ dlltool API.dll -z API.def --export-all-symbols @end example Note that if some routines in the DLL have the @code{Stdcall} convention -(@ref{1e6,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}} +(@ref{1e7,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}} suffix then you'll have to edit @code{api.def} to add it, and specify @code{-k} to @code{gnatdll} when creating the import library. @@ -24765,13 +24888,13 @@ tells you what symbol is expected. You just have to go back to the definition file and add the right suffix. @end itemize @end quotation -@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1f9} +@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1fa} @subsubheading GNAT-Style Import Library To create a static import library from @code{API.dll} with the GNAT tools you should create the .def file, then use @code{gnatdll} tool -(see @ref{1fa,,Using gnatdll}) as follows: +(see @ref{1fb,,Using gnatdll}) as follows: @quotation @@ -24787,15 +24910,15 @@ definition file name is @code{xyz.def}, the import library name will be @code{libxyz.a}. Note that in the previous example option @code{-e} could have been removed because the name of the definition file (before the @code{.def} suffix) is the same as the name of the -DLL (@ref{1fa,,Using gnatdll} for more information about @code{gnatdll}). +DLL (@ref{1fb,,Using gnatdll} for more information about @code{gnatdll}). @end quotation -@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1fb} +@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{1fc} @subsubheading Microsoft-Style Import Library A Microsoft import library is needed only if you plan to make an Ada DLL available to applications developed with Microsoft -tools (@ref{1e3,,Mixed-Language Programming on Windows}). +tools (@ref{1e4,,Mixed-Language Programming on Windows}). To create a Microsoft-style import library for @code{API.dll} you should create the .def file, then build the actual import library using @@ -24819,7 +24942,7 @@ See the Microsoft documentation for further details about the usage of @end quotation @node Building DLLs with GNAT Project files,Building DLLs with GNAT,Using DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id23}@anchor{1fc}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1e5} +@anchor{gnat_ugn/platform_specific_information id23}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1e6} @subsubsection Building DLLs with GNAT Project files @@ -24835,7 +24958,7 @@ when inside the @code{DllMain} routine which is used for auto-initialization of shared libraries, so it is not possible to have library level tasks in SALs. @node Building DLLs with GNAT,Building DLLs with gnatdll,Building DLLs with GNAT Project files,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1fd}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1fe} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{1fe}@anchor{gnat_ugn/platform_specific_information id24}@anchor{1ff} @subsubsection Building DLLs with GNAT @@ -24866,7 +24989,7 @@ $ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o ... It is important to note that in this case all symbols found in the object files are automatically exported. It is possible to restrict the set of symbols to export by passing to @code{gcc} a definition -file (see @ref{1f2,,The Definition File}). +file (see @ref{1f3,,The Definition File}). For example: @example @@ -24904,7 +25027,7 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @end quotation @node Building DLLs with gnatdll,Ada DLLs and Finalization,Building DLLs with GNAT,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{1ff}@anchor{gnat_ugn/platform_specific_information id25}@anchor{200} +@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{200}@anchor{gnat_ugn/platform_specific_information id25}@anchor{201} @subsubsection Building DLLs with gnatdll @@ -24912,8 +25035,8 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI @geindex building Note that it is preferred to use GNAT Project files -(@ref{1e5,,Building DLLs with GNAT Project files}) or the built-in GNAT -DLL support (@ref{1fd,,Building DLLs with GNAT}) or to build DLLs. +(@ref{1e6,,Building DLLs with GNAT Project files}) or the built-in GNAT +DLL support (@ref{1fe,,Building DLLs with GNAT}) or to build DLLs. This section explains how to build DLLs containing Ada code using @code{gnatdll}. These DLLs will be referred to as Ada DLLs in the @@ -24929,20 +25052,20 @@ non-Ada applications are as follows: You need to mark each Ada entity exported by the DLL with a @code{C} or @code{Stdcall} calling convention to avoid any Ada name mangling for the entities exported by the DLL -(see @ref{201,,Exporting Ada Entities}). You can +(see @ref{202,,Exporting Ada Entities}). You can skip this step if you plan to use the Ada DLL only from Ada applications. @item Your Ada code must export an initialization routine which calls the routine @code{adainit} generated by @code{gnatbind} to perform the elaboration of -the Ada code in the DLL (@ref{202,,Ada DLLs and Elaboration}). The initialization +the Ada code in the DLL (@ref{203,,Ada DLLs and Elaboration}). The initialization routine exported by the Ada DLL must be invoked by the clients of the DLL to initialize the DLL. @item When useful, the DLL should also export a finalization routine which calls routine @code{adafinal} generated by @code{gnatbind} to perform the -finalization of the Ada code in the DLL (@ref{203,,Ada DLLs and Finalization}). +finalization of the Ada code in the DLL (@ref{204,,Ada DLLs and Finalization}). The finalization routine exported by the Ada DLL must be invoked by the clients of the DLL when the DLL services are no further needed. @@ -24952,11 +25075,11 @@ of the programming languages to which you plan to make the DLL available. @item You must provide a definition file listing the exported entities -(@ref{1f2,,The Definition File}). +(@ref{1f3,,The Definition File}). @item Finally you must use @code{gnatdll} to produce the DLL and the import -library (@ref{1fa,,Using gnatdll}). +library (@ref{1fb,,Using gnatdll}). @end itemize Note that a relocatable DLL stripped using the @code{strip} @@ -24976,7 +25099,7 @@ chapter of the @emph{GPRbuild User's Guide}. @end menu @node Limitations When Using Ada DLLs from Ada,Exporting Ada Entities,,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{204} +@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{205} @subsubsection Limitations When Using Ada DLLs from Ada @@ -24997,7 +25120,7 @@ It is completely safe to exchange plain elementary, array or record types, Windows object handles, etc. @node Exporting Ada Entities,Ada DLLs and Elaboration,Limitations When Using Ada DLLs from Ada,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{201}@anchor{gnat_ugn/platform_specific_information id26}@anchor{205} +@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{202}@anchor{gnat_ugn/platform_specific_information id26}@anchor{206} @subsubsection Exporting Ada Entities @@ -25097,10 +25220,10 @@ end API; Note that if you do not export the Ada entities with a @code{C} or @code{Stdcall} convention you will have to provide the mangled Ada names in the definition file of the Ada DLL -(@ref{206,,Creating the Definition File}). +(@ref{207,,Creating the Definition File}). @node Ada DLLs and Elaboration,,Exporting Ada Entities,Building DLLs with gnatdll -@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{202}@anchor{gnat_ugn/platform_specific_information id27}@anchor{207} +@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{203}@anchor{gnat_ugn/platform_specific_information id27}@anchor{208} @subsubsection Ada DLLs and Elaboration @@ -25118,7 +25241,7 @@ the Ada elaboration routine @code{adainit} generated by the GNAT binder (@ref{b4,,Binding with Non-Ada Main Programs}). See the body of @code{Initialize_Api} for an example. Note that the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} -tool (@ref{1fa,,Using gnatdll}). +tool (@ref{1fb,,Using gnatdll}). When a DLL is loaded, Windows systematically invokes a routine called @code{DllMain}. It would therefore be possible to call @code{adainit} @@ -25131,7 +25254,7 @@ time), which means that the GNAT run-time will deadlock waiting for the newly created task to complete its initialization. @node Ada DLLs and Finalization,Creating a Spec for Ada DLLs,Building DLLs with gnatdll,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id28}@anchor{208}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{203} +@anchor{gnat_ugn/platform_specific_information id28}@anchor{209}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{204} @subsubsection Ada DLLs and Finalization @@ -25146,10 +25269,10 @@ routine @code{adafinal} generated by the GNAT binder See the body of @code{Finalize_Api} for an example. As already pointed out the GNAT binder is automatically invoked during the DLL build process by the @code{gnatdll} tool -(@ref{1fa,,Using gnatdll}). +(@ref{1fb,,Using gnatdll}). @node Creating a Spec for Ada DLLs,GNAT and Windows Resources,Ada DLLs and Finalization,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id29}@anchor{209}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{20a} +@anchor{gnat_ugn/platform_specific_information id29}@anchor{20a}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{20b} @subsubsection Creating a Spec for Ada DLLs @@ -25207,7 +25330,7 @@ end API; @end menu @node Creating the Definition File,Using gnatdll,,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{206}@anchor{gnat_ugn/platform_specific_information id30}@anchor{20b} +@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{207}@anchor{gnat_ugn/platform_specific_information id30}@anchor{20c} @subsubsection Creating the Definition File @@ -25243,7 +25366,7 @@ EXPORTS @end quotation @node Using gnatdll,,Creating the Definition File,Creating a Spec for Ada DLLs -@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1fa}@anchor{gnat_ugn/platform_specific_information id31}@anchor{20c} +@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{1fb}@anchor{gnat_ugn/platform_specific_information id31}@anchor{20d} @subsubsection Using @code{gnatdll} @@ -25454,7 +25577,7 @@ asks @code{gnatlink} to generate the routines @code{DllMain} and is loaded into memory. @item -@code{gnatdll} uses @code{dlltool} (see @ref{20d,,Using dlltool}) to build the +@code{gnatdll} uses @code{dlltool} (see @ref{20e,,Using dlltool}) to build the export table (@code{api.exp}). The export table contains the relocation information in a form which can be used during the final link to ensure that the Windows loader is able to place the DLL anywhere in memory. @@ -25493,7 +25616,7 @@ $ gnatbind -n api $ gnatlink api api.exp -o api.dll -mdll @end example @end itemize -@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{20d} +@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{20e} @subsubheading Using @code{dlltool} @@ -25552,7 +25675,7 @@ DLL in the static import library generated by @code{dlltool} with switch @item @code{-k} Kill @code{@@@emph{nn}} from exported names -(@ref{1e6,,Windows Calling Conventions} +(@ref{1e7,,Windows Calling Conventions} for a discussion about @code{Stdcall}-style symbols. @end table @@ -25608,7 +25731,7 @@ Use @code{assembler-name} as the assembler. The default is @code{as}. @end table @node GNAT and Windows Resources,Using GNAT DLLs from Microsoft Visual Studio Applications,Creating a Spec for Ada DLLs,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{20e}@anchor{gnat_ugn/platform_specific_information id32}@anchor{20f} +@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{20f}@anchor{gnat_ugn/platform_specific_information id32}@anchor{210} @subsubsection GNAT and Windows Resources @@ -25703,7 +25826,7 @@ the corresponding Microsoft documentation. @end menu @node Building Resources,Compiling Resources,,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{210}@anchor{gnat_ugn/platform_specific_information id33}@anchor{211} +@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{211}@anchor{gnat_ugn/platform_specific_information id33}@anchor{212} @subsubsection Building Resources @@ -25723,7 +25846,7 @@ complete description of the resource script language can be found in the Microsoft documentation. @node Compiling Resources,Using Resources,Building Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{212}@anchor{gnat_ugn/platform_specific_information id34}@anchor{213} +@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{213}@anchor{gnat_ugn/platform_specific_information id34}@anchor{214} @subsubsection Compiling Resources @@ -25765,7 +25888,7 @@ $ windres -i myres.res -o myres.o @end quotation @node Using Resources,,Compiling Resources,GNAT and Windows Resources -@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{214}@anchor{gnat_ugn/platform_specific_information id35}@anchor{215} +@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{215}@anchor{gnat_ugn/platform_specific_information id35}@anchor{216} @subsubsection Using Resources @@ -25785,7 +25908,7 @@ $ gnatmake myprog -largs myres.o @end quotation @node Using GNAT DLLs from Microsoft Visual Studio Applications,Debugging a DLL,GNAT and Windows Resources,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{216}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{217} +@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{217}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{218} @subsubsection Using GNAT DLLs from Microsoft Visual Studio Applications @@ -25819,7 +25942,7 @@ $ gprbuild -p mylib.gpr @item Produce a .def file for the symbols you need to interface with, either by hand or automatically with possibly some manual adjustments -(see @ref{1f8,,Creating Definition File Automatically}): +(see @ref{1f9,,Creating Definition File Automatically}): @end enumerate @quotation @@ -25836,7 +25959,7 @@ $ dlltool libmylib.dll -z libmylib.def --export-all-symbols Make sure that MSVS command-line tools are accessible on the path. @item -Create the Microsoft-style import library (see @ref{1fb,,MSVS-Style Import Library}): +Create the Microsoft-style import library (see @ref{1fc,,MSVS-Style Import Library}): @end enumerate @quotation @@ -25878,7 +26001,7 @@ or copy the DLL into into the directory containing the .exe. @end enumerate @node Debugging a DLL,Setting Stack Size from gnatlink,Using GNAT DLLs from Microsoft Visual Studio Applications,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information id36}@anchor{218}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{219} +@anchor{gnat_ugn/platform_specific_information id36}@anchor{219}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{21a} @subsubsection Debugging a DLL @@ -25916,7 +26039,7 @@ tools suite used to build the DLL. @end menu @node Program and DLL Both Built with GCC/GNAT,Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information id37}@anchor{21a}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{21b} +@anchor{gnat_ugn/platform_specific_information id37}@anchor{21b}@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{21c} @subsubsection Program and DLL Both Built with GCC/GNAT @@ -25926,7 +26049,7 @@ the process. Let's suppose here that the main procedure is named @code{ada_main} and that in the DLL there is an entry point named @code{ada_dll}. -The DLL (@ref{1f1,,Introduction to Dynamic Link Libraries (DLLs)}) and +The DLL (@ref{1f2,,Introduction to Dynamic Link Libraries (DLLs)}) and program must have been built with the debugging information (see GNAT -g switch). Here are the step-by-step instructions for debugging it: @@ -25966,7 +26089,7 @@ you can use the standard approach to debug the whole program (@ref{24,,Running and Debugging Ada Programs}). @node Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Program and DLL Both Built with GCC/GNAT,Debugging a DLL -@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{21c}@anchor{gnat_ugn/platform_specific_information id38}@anchor{21d} +@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{21d}@anchor{gnat_ugn/platform_specific_information id38}@anchor{21e} @subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT @@ -25983,7 +26106,7 @@ example some C code built with Microsoft Visual C) and that there is a DLL named @code{test.dll} containing an Ada entry point named @code{ada_dll}. -The DLL (see @ref{1f1,,Introduction to Dynamic Link Libraries (DLLs)}) must have +The DLL (see @ref{1f2,,Introduction to Dynamic Link Libraries (DLLs)}) must have been built with debugging information (see the GNAT @code{-g} option). @subsubheading Debugging the DLL Directly @@ -26122,7 +26245,7 @@ approach to debug a program as described in @ref{24,,Running and Debugging Ada Programs}. @node Setting Stack Size from gnatlink,Setting Heap Size from gnatlink,Debugging a DLL,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{136}@anchor{gnat_ugn/platform_specific_information id39}@anchor{21e} +@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{136}@anchor{gnat_ugn/platform_specific_information id39}@anchor{21f} @subsubsection Setting Stack Size from @code{gnatlink} @@ -26165,7 +26288,7 @@ because the comma is a separator for this option. @end itemize @node Setting Heap Size from gnatlink,,Setting Stack Size from gnatlink,Mixed-Language Programming on Windows -@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{137}@anchor{gnat_ugn/platform_specific_information id40}@anchor{21f} +@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{137}@anchor{gnat_ugn/platform_specific_information id40}@anchor{220} @subsubsection Setting Heap Size from @code{gnatlink} @@ -26198,7 +26321,7 @@ because the comma is a separator for this option. @end itemize @node Windows Specific Add-Ons,,Mixed-Language Programming on Windows,Microsoft Windows Topics -@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{220}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{221} +@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{221}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{222} @subsection Windows Specific Add-Ons @@ -26211,7 +26334,7 @@ This section describes the Windows specific add-ons. @end menu @node Win32Ada,wPOSIX,,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{222}@anchor{gnat_ugn/platform_specific_information id41}@anchor{223} +@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{223}@anchor{gnat_ugn/platform_specific_information id41}@anchor{224} @subsubsection Win32Ada @@ -26242,7 +26365,7 @@ gprbuild p.gpr @end quotation @node wPOSIX,,Win32Ada,Windows Specific Add-Ons -@anchor{gnat_ugn/platform_specific_information id42}@anchor{224}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{225} +@anchor{gnat_ugn/platform_specific_information id42}@anchor{225}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{226} @subsubsection wPOSIX @@ -26275,7 +26398,7 @@ gprbuild p.gpr @end quotation @node Mac OS Topics,,Microsoft Windows Topics,Platform-Specific Information -@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2d}@anchor{gnat_ugn/platform_specific_information id43}@anchor{226} +@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2d}@anchor{gnat_ugn/platform_specific_information id43}@anchor{227} @section Mac OS Topics @@ -26290,7 +26413,7 @@ platform. @end menu @node Codesigning the Debugger,,,Mac OS Topics -@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{227} +@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{228} @subsection Codesigning the Debugger @@ -26371,7 +26494,7 @@ the location where you installed GNAT. Also, be sure that users are in the Unix group @code{_developer}. @node Example of Binder Output File,Elaboration Order Handling in GNAT,Platform-Specific Information,Top -@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{228}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{229} +@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{229}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{22a} @chapter Example of Binder Output File @@ -27123,7 +27246,7 @@ elaboration code in your own application). @c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit @node Elaboration Order Handling in GNAT,Inline Assembler,Example of Binder Output File,Top -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{22a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{22b} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{22b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{22c} @chapter Elaboration Order Handling in GNAT @@ -27141,15 +27264,11 @@ GNAT, either automatically or with explicit programming features. * Checking the Elaboration Order:: * Controlling the Elaboration Order in Ada:: * Controlling the Elaboration Order in GNAT:: -* Common Elaboration-model Traits:: -* Dynamic Elaboration Model in GNAT:: -* Static Elaboration Model in GNAT:: -* SPARK Elaboration Model in GNAT:: -* Legacy Elaboration Model in GNAT:: * Mixing Elaboration Models:: +* ABE Diagnostics:: +* SPARK Diagnostics:: * Elaboration Circularities:: * Resolving Elaboration Circularities:: -* Resolving Task Issues:: * Elaboration-related Compiler Switches:: * Summary of Procedures for Elaboration Control:: * Inspecting the Chosen Elaboration Order:: @@ -27157,7 +27276,7 @@ GNAT, either automatically or with explicit programming features. @end menu @node Elaboration Code,Elaboration Order,,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{22c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{22d} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{22d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{22e} @section Elaboration Code @@ -27197,9 +27316,15 @@ In addition to the Ada terminology, this appendix defines the following terms: @itemize * @item +@emph{Invocation} + +The act of calling a subprogram, instantiating a generic, or activating a +task. + +@item @emph{Scenario} -A construct that is elaborated or executed by elaboration code is referred to +A construct that is elaborated or invoked by elaboration code is referred to as an @emph{elaboration scenario} or simply a @strong{scenario}. GNAT recognizes the following scenarios: @@ -27271,7 +27396,7 @@ end Client; In the example above, the call to @code{Server.Func} is an elaboration scenario because it appears at the library level of package @code{Client}. Note that the declaration of package @code{Nested} is ignored according to the definition -given above. As a result, the call to @code{Server.Func} will be executed when +given above. As a result, the call to @code{Server.Func} will be invoked when the spec of unit @code{Client} is elaborated. @item @@ -27294,12 +27419,12 @@ end Client; In the example above, the call to @code{Proc} is an elaboration scenario because it appears within the statement sequence of package body @code{Client}. As a -result, the call to @code{Proc} will be executed when the body of @code{Client} is +result, the call to @code{Proc} will be invoked when the body of @code{Client} is elaborated. @end itemize @node Elaboration Order,Checking the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{22e}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{22f} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order}@anchor{22f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{230} @section Elaboration Order @@ -27308,6 +27433,8 @@ executed is referred to as @strong{elaboration order}. Within a single unit, elaboration code is executed in sequential order. +@quotation + @example package body Client is Result : ... := Server.Func; @@ -27321,6 +27448,7 @@ begin Proc; end Client; @end example +@end quotation In the example above, the elaboration order within package body @code{Client} is as follows: @@ -27368,17 +27496,25 @@ factors: @emph{with}ed units @item +parent units + +@item purity of units @item preelaborability of units @item -presence of elaboration control pragmas +presence of elaboration-control pragmas + +@item +invocations performed in elaboration code @end itemize A program may have several elaboration orders depending on its structure. +@quotation + @example package Server is function Func (Index : Integer) return Integer; @@ -27407,16 +27543,20 @@ end Client; with Client; procedure Main is begin null; end Main; @end example +@end quotation The following elaboration order exhibits a fundamental problem referred to as @emph{access-before-elaboration} or simply @strong{ABE}. +@quotation + @example spec of Server spec of Client body of Server body of Main @end example +@end quotation The elaboration of @code{Server}'s spec materializes function @code{Func}, making it callable. The elaboration of @code{Client}'s spec elaborates the declaration of @@ -27434,26 +27574,30 @@ vein as index or null exclusion checks. A failed ABE check raises exception The following elaboration order avoids the ABE problem and the program can be successfully elaborated. +@quotation + @example spec of Server body of Server spec of Client body of Main @end example +@end quotation Ada states that a total elaboration order must exist, but it does not define what this order is. A compiler is thus tasked with choosing a suitable elaboration order which satisfies the dependencies imposed by @emph{with} clauses, -unit categorization, and elaboration control pragmas. Ideally an order which -avoids ABE problems should be chosen, however a compiler may not always find -such an order due to complications with respect to control and data flow. +unit categorization, elaboration-control pragmas, and invocations performed in +elaboration code. Ideally an order that avoids ABE problems should be chosen, +however a compiler may not always find such an order due to complications with +respect to control and data flow. @node Checking the Elaboration Order,Controlling the Elaboration Order in Ada,Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{231} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{231}@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{232} @section Checking the Elaboration Order -To avoid placing the entire elaboration order burden on the programmer, Ada +To avoid placing the entire elaboration-order burden on the programmer, Ada provides three lines of defense: @@ -27471,7 +27615,7 @@ always elaborated prior to Client. The same principle applies to child units @emph{Dynamic semantics} Dynamic checks are performed at run time, to ensure that a target is -elaborated prior to a scenario that executes it, thus avoiding ABE problems. +elaborated prior to a scenario that invokes it, thus avoiding ABE problems. A failed run-time check raises exception @code{Program_Error}. The following restrictions apply: @@ -27500,8 +27644,7 @@ associated task type has been elaborated. The restrictions above can be summarized by the following rule: @emph{If a target has a body, then this body must be elaborated prior to the -execution of the scenario that invokes, instantiates, or activates the -target.} +scenario that invokes the target.} @item @emph{Elaboration control} @@ -27511,7 +27654,7 @@ order. @end itemize @node Controlling the Elaboration Order in Ada,Controlling the Elaboration Order in GNAT,Checking the Elaboration Order,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{233} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-ada}@anchor{233}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{234} @section Controlling the Elaboration Order in Ada @@ -27577,7 +27720,7 @@ but still strong enough to prevent ABE problems within a unit. Pragma @code{Elaborate_Body} requires that the body of a unit is elaborated immediately after its spec. This restriction guarantees that no client -scenario can execute a server target before the target body has been +scenario can invoke a server target before the target body has been elaborated because the spec and body are effectively "glued" together. @example @@ -27777,7 +27920,7 @@ Note that there are several allowable suborders for the specs and bodies of be elaborated prior to @code{Client}. Removing pragma @code{Elaborate_All} could result in the following incorrect -elaboration order +elaboration order: @example spec of Math @@ -27838,8 +27981,8 @@ Note that one additional advantage of using @code{Elaborate} and @code{Elaborate is that the program continues to stay in the last state (one or more correct orders exist) even if maintenance changes the bodies of targets. -@node Controlling the Elaboration Order in GNAT,Common Elaboration-model Traits,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{235} +@node Controlling the Elaboration Order in GNAT,Mixing Elaboration Models,Controlling the Elaboration Order in Ada,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{235}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order-in-gnat}@anchor{236} @section Controlling the Elaboration Order in GNAT @@ -27855,12 +27998,34 @@ elaboration order and to diagnose elaboration problems. @item @emph{Dynamic elaboration model} -This is the most permissive of the three elaboration models. When the -dynamic model is in effect, GNAT assumes that all code within all units in -a partition is elaboration code. GNAT performs very few diagnostics and -generates run-time checks to verify the elaboration order of a program. This -behavior is identical to that specified by the Ada Reference Manual. The -dynamic model is enabled with compiler switch @code{-gnatE}. +This is the most permissive of the three elaboration models and emulates the +behavior specified by the Ada Reference Manual. When the dynamic model is in +effect, GNAT makes the following assumptions: + + +@itemize - + +@item +All code within all units in a partition is considered to be elaboration +code. + +@item +Some of the invocations in elaboration code may not take place at run time +due to conditional execution. +@end itemize + +GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios +that invoke internal targets. In addition, GNAT generates run-time checks for +all external targets and for all scenarios that may exhibit ABE problems. + +The elaboration order is obtained by honoring all @emph{with} clauses, purity and +preelaborability of units, and elaboration-control pragmas. The dynamic model +attempts to take all invocations in elaboration code into account. If an +invocation leads to a circularity, GNAT ignores the invocation based on the +assumptions stated above. An order obtained using the dynamic model may fail +an ABE check at run time when GNAT ignored an invocation. + +The dynamic model is enabled with compiler switch @code{-gnatE}. @end itemize @geindex Static elaboration model @@ -27872,12 +28037,31 @@ dynamic model is enabled with compiler switch @code{-gnatE}. @emph{Static elaboration model} This is the middle ground of the three models. When the static model is in -effect, GNAT performs extensive diagnostics on a unit-by-unit basis for all -scenarios that elaborate or execute internal targets. GNAT also generates -run-time checks for all external targets and for all scenarios that may -exhibit ABE problems. Finally, GNAT installs implicit @code{Elaborate} and -@code{Elaborate_All} pragmas for server units based on the dependencies of -client units. The static model is the default model in GNAT. +effect, GNAT makes the following assumptions: + + +@itemize - + +@item +Only code at the library level and in package body statements within all +units in a partition is considered to be elaboration code. + +@item +All invocations in elaboration will take place at run time, regardless of +conditional execution. +@end itemize + +GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios +that invoke internal targets. In addition, GNAT generates run-time checks for +all external targets and for all scenarios that may exhibit ABE problems. + +The elaboration order is obtained by honoring all @emph{with} clauses, purity and +preelaborability of units, presence of elaboration-control pragmas, and all +invocations in elaboration code. An order obtained using the static model is +guaranteed to be ABE problem-free, excluding dispatching calls and +access-to-subprogram types. + +The static model is the default model in GNAT. @end itemize @geindex SPARK elaboration model @@ -27891,21 +28075,34 @@ client units. The static model is the default model in GNAT. This is the most conservative of the three models and enforces the SPARK rules of elaboration as defined in the SPARK Reference Manual, section 7.7. The SPARK model is in effect only when a scenario and a target reside in a -region subject to SPARK_Mode On, otherwise the dynamic or static model is in -effect. +region subject to @code{SPARK_Mode On}, otherwise the dynamic or static model +is in effect. + +The SPARK model is enabled with compiler switch @code{-gnatd.v}. @end itemize -@geindex Legacy elaboration model +@geindex Legacy elaboration models @itemize * @item -@emph{Legacy elaboration model} +@emph{Legacy elaboration models} In addition to the three elaboration models outlined above, GNAT provides the -elaboration model of pre-18.x versions referred to as @cite{legacy elaboration model}. The legacy elaboration model is enabled with compiler switch -@code{-gnatH}. +following legacy models: + + +@itemize - + +@item +@cite{Legacy elaboration-checking model} available in pre-18.x versions of GNAT. +This model is enabled with compiler switch @code{-gnatH}. + +@item +@cite{Legacy elaboration-order model} available in pre-20.x versions of GNAT. +This model is enabled with binder switch @code{-H}. +@end itemize @end itemize @geindex Relaxed elaboration mode @@ -27914,32 +28111,72 @@ The dynamic, legacy, and static models can be relaxed using compiler switch @code{-gnatJ}, making them more permissive. Note that in this mode, GNAT may not diagnose certain elaboration issues or install run-time checks. -@node Common Elaboration-model Traits,Dynamic Elaboration Model in GNAT,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat common-elaboration-model-traits}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{237} -@section Common Elaboration-model Traits +@node Mixing Elaboration Models,ABE Diagnostics,Controlling the Elaboration Order in GNAT,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{237}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{238} +@section Mixing Elaboration Models -All three GNAT models are able to detect elaboration problems related to -dispatching calls and a particular kind of ABE referred to as @emph{guaranteed ABE}. +It is possible to mix units compiled with a different elaboration model, +however the following rules must be observed: @itemize * @item -@emph{Dispatching calls} +A client unit compiled with the dynamic model can only @emph{with} a server unit +that meets at least one of the following criteria: + + +@itemize - + +@item +The server unit is compiled with the dynamic model. -GNAT installs run-time checks for each primitive subprogram of each tagged -type defined in a partition on the assumption that a dispatching call -invoked at elaboration time will execute one of these primitives. As a -result, a dispatching call that executes a primitive whose body has not -been elaborated yet will raise exception @code{Program_Error} at run time. The -checks can be suppressed using pragma @code{Suppress (Elaboration_Check)}. +@item +The server unit is a GNAT implementation unit from the @code{Ada}, @code{GNAT}, +@code{Interfaces}, or @code{System} hierarchies. + +@item +The server unit has pragma @code{Pure} or @code{Preelaborate}. @item -@emph{Guaranteed ABE} +The client unit has an explicit @code{Elaborate_All} pragma for the server +unit. +@end itemize +@end itemize + +These rules ensure that elaboration checks are not omitted. If the rules are +violated, the binder emits a warning: -A guaranteed ABE arises when the body of a target is not elaborated early -enough, and causes all scenarios that directly execute the target to fail. +@quotation + +@example +warning: "x.ads" has dynamic elaboration checks and with's +warning: "y.ads" which has static elaboration checks +@end example +@end quotation + +The warnings can be suppressed by binder switch @code{-ws}. + +@node ABE Diagnostics,SPARK Diagnostics,Mixing Elaboration Models,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat abe-diagnostics}@anchor{239}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{23a} +@section ABE Diagnostics + + +GNAT performs extensive diagnostics on a unit-by-unit basis for all scenarios +that invoke internal targets, regardless of whether the dynamic, SPARK, or +static model is in effect. + +Note that GNAT emits warnings rather than hard errors whenever it encounters an +elaboration problem. This is because the elaboration model in effect may be too +conservative, or a particular scenario may not be invoked due conditional +execution. The warnings can be suppressed selectively with @code{pragma Warnings +(Off)} or globally with compiler switch @code{-gnatwL}. + +A @emph{guaranteed ABE} arises when the body of a target is not elaborated early +enough, and causes @emph{all} scenarios that directly invoke the target to fail. + +@quotation @example package body Guaranteed_ABE is @@ -27949,843 +28186,484 @@ package body Guaranteed_ABE is function ABE return Integer is begin - ... + ... end ABE; end Guaranteed_ABE; @end example +@end quotation In the example above, the elaboration of @code{Guaranteed_ABE}'s body elaborates -the declaration of @code{Val}. This invokes function @code{ABE}, however the body -of @code{ABE} has not been elaborated yet. GNAT emits similar diagnostics in all -three models: +the declaration of @code{Val}. This invokes function @code{ABE}, however the body of +@code{ABE} has not been elaborated yet. GNAT emits the following diagnostic: + +@quotation @example -1. package body Guaranteed_ABE is -2. function ABE return Integer; -3. 4. Val : constant Integer := ABE; | >>> warning: cannot call "ABE" before body seen >>> warning: Program_Error will be raised at run time - -5. -6. function ABE return Integer is -7. begin -8. ... -9. end ABE; -10. end Guaranteed_ABE; @end example -@end itemize - -Note that GNAT emits warnings rather than hard errors whenever it encounters an -elaboration problem. This is because the elaboration model in effect may be too -conservative, or a particular scenario may not be elaborated or executed due to -data and control flow. The warnings can be suppressed selectively with @code{pragma -Warnigns (Off)} or globally with compiler switch @code{-gnatwL}. - -@node Dynamic Elaboration Model in GNAT,Static Elaboration Model in GNAT,Common Elaboration-model Traits,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat dynamic-elaboration-model-in-gnat}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{239} -@section Dynamic Elaboration Model in GNAT +@end quotation +A @emph{conditional ABE} arises when the body of a target is not elaborated early +enough, and causes @emph{some} scenarios that directly invoke the target to fail. -The dynamic model assumes that all code within all units in a partition is -elaboration code. As a result, run-time checks are installed for each scenario -regardless of whether the target is internal or external. The checks can be -suppressed using pragma @code{Suppress (Elaboration_Check)}. This behavior is -identical to that specified by the Ada Reference Manual. The following example -showcases run-time checks installed by GNAT to verify the elaboration state of -package @code{Dynamic_Model}. +@quotation @example -with Server; -package body Dynamic_Model is - procedure API is - begin - ... - end API; - - <check that the body of Server.Gen is elaborated> - package Inst is new Server.Gen; + 1. package body Conditional_ABE is + 2. procedure Force_Body is null; + 3. + 4. generic + 5. with function Func return Integer; + 6. package Gen is + 7. Val : constant Integer := Func; + 8. end Gen; + 9. +10. function ABE return Integer; +11. +12. function Cause_ABE return Boolean is +13. package Inst is new Gen (ABE); +14. begin +15. ... +16. end Cause_ABE; +17. +18. Val : constant Boolean := Cause_ABE; +19. +20. function ABE return Integer is +21. begin +22. ... +23. end ABE; +24. +25. Safe : constant Boolean := Cause_ABE; +26. end Conditional_ABE; +@end example +@end quotation - T : Server.Task_Type; +In the example above, the elaboration of package body @code{Conditional_ABE} +elaborates the declaration of @code{Val}. This invokes function @code{Cause_ABE}, +which instantiates generic unit @code{Gen} as @code{Inst}. The elaboration of +@code{Inst} invokes function @code{ABE}, however the body of @code{ABE} has not been +elaborated yet. GNAT emits the following diagnostic: -begin - <check that the body of Server.Task_Type is elaborated> +@quotation - <check that the body of Server.Proc is elaborated> - Server.Proc; -end Dynamic_Model; +@example +13. package Inst is new Gen (ABE); + | + >>> warning: in instantiation at line 7 + >>> warning: cannot call "ABE" before body seen + >>> warning: Program_Error may be raised at run time + >>> warning: body of unit "Conditional_ABE" elaborated + >>> warning: function "Cause_ABE" called at line 18 + >>> warning: function "ABE" called at line 7, instance at line 13 @end example +@end quotation -The checks verify that the body of a target has been successfully elaborated -before a scenario activates, calls, or instantiates a target. +Note that the same ABE problem does not occur with the elaboration of +declaration @code{Safe} because the body of function @code{ABE} has already been +elaborated at that point. -Note that no scenario within package @code{Dynamic_Model} calls procedure @code{API}. -In fact, procedure @code{API} may not be invoked by elaboration code within the -partition, however the dynamic model assumes that this can happen. +@node SPARK Diagnostics,Elaboration Circularities,ABE Diagnostics,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-diagnostics}@anchor{23b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23c} +@section SPARK Diagnostics -The dynamic model emits very few diagnostics, but can make suggestions on -missing @code{Elaborate} and @code{Elaborate_All} pragmas for library-level -scenarios. This information is available when compiler switch @code{-gnatel} -is in effect. + +GNAT enforces the SPARK rules of elaboration as defined in the SPARK Reference +Manual section 7.7 when compiler switch @code{-gnatd.v} is in effect. Note +that GNAT emits hard errors whenever it encounters a violation of the SPARK +rules. + +@quotation @example 1. with Server; -2. package body Dynamic_Model is +2. package body SPARK_Diagnostics with SPARK_Mode is 3. Val : constant Integer := Server.Func; | - >>> info: call to "Func" during elaboration - >>> info: missing pragma "Elaborate_All" for unit "Server" + >>> call to "Func" during elaboration in SPARK + >>> unit "SPARK_Diagnostics" requires pragma "Elaborate_All" for "Server" + >>> body of unit "SPARK_Model" elaborated + >>> function "Func" called at line 3 -4. end Dynamic_Model; +4. end SPARK_Diagnostics; @end example +@end quotation -@node Static Elaboration Model in GNAT,SPARK Elaboration Model in GNAT,Dynamic Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat static-elaboration-model-in-gnat}@anchor{23a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{23b} -@section Static Elaboration Model in GNAT - +@node Elaboration Circularities,Resolving Elaboration Circularities,SPARK Diagnostics,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23d}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{23e} +@section Elaboration Circularities -In contrast to the dynamic model, the static model is more precise in its -analysis of elaboration code. The model makes a clear distinction between -internal and external targets, and resorts to different diagnostics and -run-time checks based on the nature of the target. +An @strong{elaboration circularity} occurs whenever the elaboration of a set of +units enters a deadlocked state, where each unit is waiting for another unit +to be elaborated. This situation may be the result of improper use of @emph{with} +clauses, elaboration-control pragmas, or invocations in elaboration code. -@itemize * +The following example exhibits an elaboration circularity. -@item -@emph{Internal targets} +@quotation -The static model performs extensive diagnostics on scenarios which elaborate -or execute internal targets. The warnings resulting from these diagnostics -are enabled by default, but can be suppressed selectively with @code{pragma -Warnings (Off)} or globally with compiler switch @code{-gnatwL}. +@example +with B; pragma Elaborate (B); +package A is +end A; +@end example @example - 1. package body Static_Model is - 2. generic - 3. with function Func return Integer; - 4. package Gen is - 5. Val : constant Integer := Func; - 6. end Gen; - 7. - 8. function ABE return Integer; - 9. -10. function Cause_ABE return Boolean is -11. package Inst is new Gen (ABE); - | - >>> warning: in instantiation at line 5 - >>> warning: cannot call "ABE" before body seen - >>> warning: Program_Error may be raised at run time - >>> warning: body of unit "Static_Model" elaborated - >>> warning: function "Cause_ABE" called at line 16 - >>> warning: function "ABE" called at line 5, instance at line 11 - -12. begin -13. ... -14. end Cause_ABE; -15. -16. Val : constant Boolean := Cause_ABE; -17. -18. function ABE return Integer is -19. begin -20. ... -21. end ABE; -22. end Static_Model; +package B is + procedure Force_Body; +end B; @end example -The example above illustrates an ABE problem within package @code{Static_Model}, -which is hidden by several layers of indirection. The elaboration of package -body @code{Static_Model} elaborates the declaration of @code{Val}. This invokes -function @code{Cause_ABE}, which instantiates generic unit @code{Gen} as @code{Inst}. -The elaboration of @code{Inst} invokes function @code{ABE}, however the body of -@code{ABE} has not been elaborated yet. +@example +with C; +package body B is + procedure Force_Body is null; -@item -@emph{External targets} + Elab : constant Integer := C.Func; +end B; +@end example -The static model installs run-time checks to verify the elaboration status -of server targets only when the scenario that elaborates or executes that -target is part of the elaboration code of the client unit. The checks can be -suppressed using pragma @code{Suppress (Elaboration_Check)}. +@example +package C is + function Func return Integer; +end C; +@end example @example -with Server; -package body Static_Model is - generic - with function Func return Integer; - package Gen is - Val : constant Integer := Func; - end Gen; - - function Call_Func return Boolean is - <check that the body of Server.Func is elaborated> - package Inst is new Gen (Server.Func); +with A; +package body C is + function Func return Integer is begin ... - end Call_Func; - - Val : constant Boolean := Call_Func; -end Static_Model; -@end example - -In the example above, the elaboration of package body @code{Static_Model} -elaborates the declaration of @code{Val}. This invokes function @code{Call_Func}, -which instantiates generic unit @code{Gen} as @code{Inst}. The elaboration of -@code{Inst} invokes function @code{Server.Func}. Since @code{Server.Func} is an -external target, GNAT installs a run-time check to verify that its body has -been elaborated. - -In addition to checks, the static model installs implicit @code{Elaborate} and -@code{Elaborate_All} pragmas to guarantee safe elaboration use of server units. -This information is available when compiler switch @code{-gnatel} is in -effect. - -@example - 1. with Server; - 2. package body Static_Model is - 3. generic - 4. with function Func return Integer; - 5. package Gen is - 6. Val : constant Integer := Func; - 7. end Gen; - 8. - 9. function Call_Func return Boolean is -10. package Inst is new Gen (Server.Func); - | - >>> info: instantiation of "Gen" during elaboration - >>> info: in instantiation at line 6 - >>> info: call to "Func" during elaboration - >>> info: in instantiation at line 6 - >>> info: implicit pragma "Elaborate_All" generated for unit "Server" - >>> info: body of unit "Static_Model" elaborated - >>> info: function "Call_Func" called at line 15 - >>> info: function "Func" called at line 6, instance at line 10 - -11. begin -12. ... -13. end Call_Func; -14. -15. Val : constant Boolean := Call_Func; - | - >>> info: call to "Call_Func" during elaboration - -16. end Static_Model; + end Func; +end C; @end example +@end quotation -In the example above, the elaboration of package body @code{Static_Model} -elaborates the declaration of @code{Val}. This invokes function @code{Call_Func}, -which instantiates generic unit @code{Gen} as @code{Inst}. The elaboration of -@code{Inst} invokes function @code{Server.Func}. Since @code{Server.Func} is an -external target, GNAT installs an implicit @code{Elaborate_All} pragma for unit -@code{Server}. The pragma guarantees that both the spec and body of @code{Server}, -along with any additional dependencies that @code{Server} may require, are -elaborated prior to the body of @code{Static_Model}. -@end itemize - -@node SPARK Elaboration Model in GNAT,Legacy Elaboration Model in GNAT,Static Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat spark-elaboration-model-in-gnat}@anchor{23d} -@section SPARK Elaboration Model in GNAT - +The binder emits the following diagnostic: -The SPARK model is identical to the static model in its handling of internal -targets. The SPARK model, however, requires explicit @code{Elaborate} or -@code{Elaborate_All} pragmas to be present in the program when a target is -external, and compiler switch @code{-gnatd.v} is in effect. +@quotation @example -1. with Server; -2. package body SPARK_Model with SPARK_Mode is -3. Val : constant Integer := Server.Func; - | - >>> call to "Func" during elaboration in SPARK - >>> unit "SPARK_Model" requires pragma "Elaborate_All" for "Server" - >>> body of unit "SPARK_Model" elaborated - >>> function "Func" called at line 3 - -4. end SPARK_Model; +error: Elaboration circularity detected +info: +info: Reason: +info: +info: unit "a (spec)" depends on its own elaboration +info: +info: Circularity: +info: +info: unit "a (spec)" has with clause and pragma Elaborate for unit "b (spec)" +info: unit "b (body)" is in the closure of pragma Elaborate +info: unit "b (body)" invokes a construct of unit "c (body)" at elaboration time +info: unit "c (body)" has with clause for unit "a (spec)" +info: +info: Suggestions: +info: +info: remove pragma Elaborate for unit "b (body)" in unit "a (spec)" +info: use the dynamic elaboration model (compiler switch -gnatE) @end example +@end quotation -@node Legacy Elaboration Model in GNAT,Mixing Elaboration Models,SPARK Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat legacy-elaboration-model-in-gnat}@anchor{23e} -@section Legacy Elaboration Model in GNAT - - -The legacy elaboration model is provided for compatibility with code bases -developed with pre-18.x versions of GNAT. It is similar in functionality to -the dynamic and static models of post-18.x version of GNAT, but may differ -in terms of diagnostics and run-time checks. The legacy elaboration model is -enabled with compiler switch @code{-gnatH}. - -@node Mixing Elaboration Models,Elaboration Circularities,Legacy Elaboration Model in GNAT,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{240} -@section Mixing Elaboration Models - - -It is possible to mix units compiled with a different elaboration model, -however the following rules must be observed: +The diagnostic consist of the following sections: @itemize * @item -A client unit compiled with the dynamic model can only @emph{with} a server unit -that meets at least one of the following criteria: +Reason - -@itemize - +This section provides a short explanation describing why the set of units +could not be ordered. @item -The server unit is compiled with the dynamic model. +Circularity -@item -The server unit is a GNAT implementation unit from the Ada, GNAT, -Interfaces, or System hierarchies. +This section enumerates the units comprising the deadlocked set, along with +their interdependencies. @item -The server unit has pragma @code{Pure} or @code{Preelaborate}. +Suggestions -@item -The client unit has an explicit @code{Elaborate_All} pragma for the server -unit. +This section enumerates various tactics for eliminating the circularity. @end itemize -@end itemize - -These rules ensure that elaboration checks are not omitted. If the rules are -violated, the binder emits a warning: -@example -warning: "x.ads" has dynamic elaboration checks and with's -warning: "y.ads" which has static elaboration checks -@end example - -The warnings can be suppressed by binder switch @code{-ws}. +@node Resolving Elaboration Circularities,Elaboration-related Compiler Switches,Elaboration Circularities,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{240} +@section Resolving Elaboration Circularities -@node Elaboration Circularities,Resolving Elaboration Circularities,Mixing Elaboration Models,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-circularities}@anchor{242} -@section Elaboration Circularities +The most desirable option from the point of view of long-term maintenance is to +rearrange the program so that the elaboration problems are avoided. One useful +technique is to place the elaboration code into separate child packages. +Another is to move some of the initialization code to explicitly invoked +subprograms, where the program controls the order of initialization explicitly. +Although this is the most desirable option, it may be impractical and involve +too much modification, especially in the case of complex legacy code. -If the binder cannot find an acceptable elaboration order, it outputs detailed -diagnostics describing an @strong{elaboration circularity}. +When faced with an elaboration circularity, the programmer should also consider +the tactics given in the suggestions section of the circularity diagnostic. +Depending on the units involved in the circularity, their @emph{with} clauses, +purity, preelaborability, presence of elaboration-control pragmas and +invocations at elaboration time, the binder may suggest one or more of the +following tactics to eliminate the circularity: -@example -package Server is - function Func return Integer; -end Server; -@end example -@example -with Client; -package body Server is - function Func return Integer is - begin - ... - end Func; -end Server; -@end example - -@example -with Server; -package Client is - Val : constant Integer := Server.Func; -end Client; -@end example +@itemize * -@example -with Client; -procedure Main is begin null; end Main; -@end example +@item +Pragma Elaborate elimination @example -error: elaboration circularity detected -info: "server (body)" must be elaborated before "client (spec)" -info: reason: implicit Elaborate_All in unit "client (spec)" -info: recompile "client (spec)" with -gnatel for full details -info: "server (body)" -info: must be elaborated along with its spec: -info: "server (spec)" -info: which is withed by: -info: "client (spec)" -info: "client (spec)" must be elaborated before "server (body)" -info: reason: with clause +remove pragma Elaborate for unit "..." in unit "..." @end example -In the example above, @code{Client} must be elaborated prior to @code{Main} by virtue -of a @emph{with} clause. The elaboration of @code{Client} invokes @code{Server.Func}, and -static model generates an implicit @code{Elaborate_All} pragma for @code{Server}. The -pragma implies that both the spec and body of @code{Server}, along with any units -they @emph{with}, must be elaborated prior to @code{Client}. However, @code{Server}'s body -@emph{with}s @code{Client}, implying that @code{Client} must be elaborated prior to -@code{Server}. The end result is that @code{Client} must be elaborated prior to -@code{Client}, and this leads to a circularity. - -@node Resolving Elaboration Circularities,Resolving Task Issues,Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{243}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-elaboration-circularities}@anchor{244} -@section Resolving Elaboration Circularities +This tactic is suggested when the binder has determined that pragma +@code{Elaborate}: -When faced with an elaboration circularity, a programmer has several options -available. +@itemize - +@item +Prevents a set of units from being elaborated. -@itemize * +@item +The removal of the pragma will not eliminate the semantic effects of the +pragma. In other words, the argument of the pragma will still be elaborated +prior to the unit containing the pragma. @item -@emph{Fix the program} +The removal of the pragma will enable the successful ordering of the units. +@end itemize -The most desirable option from the point of view of long-term maintenance -is to rearrange the program so that the elaboration problems are avoided. -One useful technique is to place the elaboration code into separate child -packages. Another is to move some of the initialization code to explicitly -invoked subprograms, where the program controls the order of initialization -explicitly. Although this is the most desirable option, it may be impractical -and involve too much modification, especially in the case of complex legacy -code. +The programmer should remove the pragma as advised, and rebuild the program. @item -@emph{Switch to more permissive elaboration model} +Pragma Elaborate_All elimination -If the compilation was performed using the static model, enable the dynamic -model with compiler switch @code{-gnatE}. GNAT will no longer generate -implicit @code{Elaborate} and @code{Elaborate_All} pragmas, resulting in a behavior -identical to that specified by the Ada Reference Manual. The binder will -generate an executable program that may or may not raise @code{Program_Error}, -and it is the programmer's responsibility to ensure that it does not raise -@code{Program_Error}. +@example +remove pragma Elaborate_All for unit "..." in unit "..." +@end example -If the compilation was performed using a post-18.x version of GNAT, consider -using the legacy elaboration model, in the following order: +This tactic is suggested when the binder has determined that pragma +@code{Elaborate_All}: @itemize - @item -Use the relaxed static elaboration model, with compiler switch -@code{-gnatJ}. +Prevents a set of units from being elaborated. @item -Use the relaxed dynamic elaboration model, with compiler switches -@code{-gnatE} @code{-gnatJ}. - -@item -Use the legacy static elaboration model, with compiler switch -@code{-gnatH}. +The removal of the pragma will not eliminate the semantic effects of the +pragma. In other words, the argument of the pragma along with its @emph{with} +closure will still be elaborated prior to the unit containing the pragma. @item -Use the legacy dynamic elaboration model, with compiler switches -@code{-gnatE} @code{-gnatH}. +The removal of the pragma will enable the successful ordering of the units. @end itemize -@item -@emph{Suppress all elaboration checks} - -The drawback of run-time checks is that they generate overhead at run time, -both in space and time. If the programmer is absolutely sure that a program -will not raise an elaboration-related @code{Program_Error}, then using the -pragma @code{Suppress (Elaboration_Check)} globally (as a configuration pragma) -will eliminate all run-time checks. +The programmer should remove the pragma as advised, and rebuild the program. @item -@emph{Suppress elaboration checks selectively} +Pragma Elaborate_All downgrade -If a scenario cannot possibly lead to an elaboration @code{Program_Error}, -and the binder nevertheless complains about implicit @code{Elaborate} and -@code{Elaborate_All} pragmas that lead to elaboration circularities, it -is possible to suppress the generation of implicit @code{Elaborate} and -@code{Elaborate_All} pragmas, as well as run-time checks. Clearly this can -be unsafe, and it is the responsibility of the programmer to make sure -that the resulting program has no elaboration anomalies. Pragma -@code{Suppress (Elaboration_Check)} can be used with different levels of -granularity to achieve these effects. +@example +change pragma Elaborate_All for unit "..." to Elaborate in unit "..." +@end example +This tactic is always suggested with the pragma @code{Elaborate_All} elimination +tactic. It offers a different alernative of guaranteeing that the argument of +the pragma will still be elaborated prior to the unit containing the pragma. -@itemize - +The programmer should update the pragma as advised, and rebuild the program. @item -@emph{Target suppression} - -When the pragma is placed in a declarative part, without a second argument -naming an entity, it will suppress implicit @code{Elaborate} and -@code{Elaborate_All} pragma generation, as well as run-time checks, on all -targets within the region. +Pragma Elaborate_Body elimination @example -package Range_Suppress is - pragma Suppress (Elaboration_Check); - - function Func return Integer; +remove pragma Elaborate_Body in unit "..." +@end example - generic - procedure Gen; +This tactic is suggested when the binder has determined that pragma +@code{Elaborate_Body}: - pragma Unsuppress (Elaboration_Check); - task type Tsk; -end Range_Suppress; -@end example +@itemize - -In the example above, a pair of Suppress/Unsuppress pragmas define a region -of suppression within package @code{Range_Suppress}. As a result, no implicit -@code{Elaborate} and @code{Elaborate_All} pragmas, nor any run-time checks, will -be generated by callers of @code{Func} and instantiators of @code{Gen}. Note that -task type @code{Tsk} is not within this region. +@item +Prevents a set of units from being elaborated. -An alternative to the region-based suppression is to use multiple -@code{Suppress} pragmas with arguments naming specific entities for which -elaboration checks should be suppressed: +@item +The removal of the pragma will enable the successful ordering of the units. +@end itemize -@example -package Range_Suppress is - function Func return Integer; - pragma Suppress (Elaboration_Check, Func); +Note that the binder cannot determine whether the pragma is required for +other purposes, such as guaranteeing the initialization of a variable +declared in the spec by elaboration code in the body. - generic - procedure Gen; - pragma Suppress (Elaboration_Check, Gen); - - task type Tsk; -end Range_Suppress; -@end example +The programmer should remove the pragma as advised, and rebuild the program. @item -@emph{Scenario suppression} - -When the pragma @code{Suppress} is placed in a declarative or statement -part, without an entity argument, it will suppress implicit @code{Elaborate} -and @code{Elaborate_All} pragma generation, as well as run-time checks, on -all scenarios within the region. +Use of pragma Restrictions @example -with Server; -package body Range_Suppress is - pragma Suppress (Elaboration_Check); - - function Func return Integer is - begin - return Server.Func; - end Func; +use pragma Restrictions (No_Entry_Calls_In_Elaboration_Code) +@end example - procedure Gen is - begin - Server.Proc; - end Gen; +This tactic is suggested when the binder has determined that a task +activation at elaboration time: - pragma Unsuppress (Elaboration_Check); - task body Tsk is - begin - Server.Proc; - end Tsk; -end Range_Suppress; -@end example +@itemize - -In the example above, a pair of Suppress/Unsuppress pragmas define a region -of suppression within package body @code{Range_Suppress}. As a result, the -calls to @code{Server.Func} in @code{Func} and @code{Server.Proc} in @code{Gen} will -not generate any implicit @code{Elaborate} and @code{Elaborate_All} pragmas or -run-time checks. -@end itemize +@item +Prevents a set of units from being elaborated. @end itemize -@node Resolving Task Issues,Elaboration-related Compiler Switches,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat resolving-task-issues}@anchor{246} -@section Resolving Task Issues +Note that the binder cannot determine with certainty whether the task will +block at elaboration time. +The programmer should create a configuration file, place the pragma within, +update the general compilation arguments, and rebuild the program. -The model of execution in Ada dictates that elaboration must first take place, -and only then can the main program be started. Tasks which are activated during -elaboration violate this model and may lead to serious concurrent problems at -elaboration time. +@item +Use of dynamic elaboration model -A task can be activated in two different ways: +@example +use the dynamic elaboration model (compiler switch -gnatE) +@end example +This tactic is suggested when the binder has determined that an invocation at +elaboration time: -@itemize * + +@itemize - @item -The task is created by an allocator in which case it is activated immediately -after the allocator is evaluated. +Prevents a set of units from being elaborated. @item -The task is declared at the library level or within some nested master in -which case it is activated before starting execution of the statement -sequence of the master defining the task. +The use of the dynamic model will enable the successful ordering of the +units. @end itemize -Since the elaboration of a partition is performed by the environment task -servicing that partition, any tasks activated during elaboration may be in -a race with the environment task, and lead to unpredictable state and behavior. -The static model seeks to avoid such interactions by assuming that all code in -the task body is executed at elaboration time, if the task was activated by -elaboration code. +The programmer has two options: -@example -package Decls is - task Lib_Task is - entry Start; - end Lib_Task; - type My_Int is new Integer; +@itemize - - function Ident (M : My_Int) return My_Int; -end Decls; -@end example +@item +Determine the units involved in the invocation using the detailed +invocation information, and add compiler switch @code{-gnatE} to the +compilation arguments of selected files only. This approach will yield +safer elaboration orders compared to the other option because it will +minimize the opportunities presented to the dynamic model for ignoring +invocations. -@example -with Utils; -package body Decls is - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; +@item +Add compiler switch @code{-gnatE} to the general compilation arguments. +@end itemize - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; -end Decls; -@end example +@item +Use of detailed invocation information @example -with Decls; -package Utils is - procedure Put_Val (Arg : Decls.My_Int); -end Utils; +use detailed invocation information (compiler switch -gnatd_F) @end example -@example -with Ada.Text_IO; use Ada.Text_IO; -package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin - Put_Line (Arg'Img); - end Put_Val; -end Utils; -@end example +This tactic is always suggested with the use of the dynamic model tactic. It +causes the circularity section of the circularity diagnostic to describe the +flow of elaboration code from a unit to a unit, enumerating all such paths in +the process. -@example -with Decls; -procedure Main is -begin - Decls.Lib_Task.Start; -end Main; -@end example +The programmer should analyze this information to determine which units +should be compiled with the dynamic model. -When the above example is compiled with the static model, an elaboration -circularity arises: +@item +Forced-dependency elimination @example -error: elaboration circularity detected -info: "decls (body)" must be elaborated before "decls (body)" -info: reason: implicit Elaborate_All in unit "decls (body)" -info: recompile "decls (body)" with -gnatel for full details -info: "decls (body)" -info: must be elaborated along with its spec: -info: "decls (spec)" -info: which is withed by: -info: "utils (spec)" -info: which is withed by: -info: "decls (body)" +remove the dependency of unit "..." on unit "..." from the argument of switch -f @end example -In the above example, @code{Decls} must be elaborated prior to @code{Main} by virtue -of a with clause. The elaboration of @code{Decls} activates task @code{Lib_Task}. The -static model conservatibely assumes that all code within the body of -@code{Lib_Task} is executed, and generates an implicit @code{Elaborate_All} pragma -for @code{Units} due to the call to @code{Utils.Put_Val}. The pragma implies that -both the spec and body of @code{Utils}, along with any units they @emph{with}, -must be elaborated prior to @code{Decls}. However, @code{Utils}'s spec @emph{with}s -@code{Decls}, implying that @code{Decls} must be elaborated before @code{Utils}. The end -result is that @code{Utils} must be elaborated prior to @code{Utils}, and this -leads to a circularity. - -In reality, the example above will not exhibit an ABE problem at run time. -When the body of task @code{Lib_Task} is activated, execution will wait for entry -@code{Start} to be accepted, and the call to @code{Utils.Put_Val} will not take place -at elaboration time. Task @code{Lib_Task} will resume its execution after the main -program is executed because @code{Main} performs a rendezvous with -@code{Lib_Task.Start}, and at that point all units have already been elaborated. -As a result, the static model may seem overly conservative, partly because it -does not take control and data flow into account. - -When faced with a task elaboration circularity, a programmer has several -options available: +This tactic is suggested when the binder has determined that a dependency +present in the forced-elaboration-order file indicated by binder switch +@code{-f}: -@itemize * +@itemize - @item -@emph{Use the dynamic model} - -The dynamic model does not generate implicit @code{Elaborate} and -@code{Elaborate_All} pragmas. Instead, it will install checks prior to every -call in the example above, thus verifying the successful elaboration of -@code{Utils.Put_Val} in case the call to it takes place at elaboration time. -The dynamic model is enabled with compiler switch @code{-gnatE}. +Prevents a set of units from being elaborated. @item -@emph{Isolate the tasks} - -Relocating tasks in their own separate package could decouple them from -dependencies that would otherwise cause an elaboration circularity. The -example above can be rewritten as follows: - -@example -package Decls1 is -- new - task Lib_Task is - entry Start; - end Lib_Task; -end Decls1; -@end example - -@example -with Utils; -package body Decls1 is -- new - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; -end Decls1; -@end example +The removal of the dependency will enable the successful ordering of the +units. +@end itemize -@example -package Decls2 is -- new - type My_Int is new Integer; - function Ident (M : My_Int) return My_Int; -end Decls2; -@end example +The programmer should edit the forced-elaboration-order file, remove the +dependency, and rebind the program. -@example -with Utils; -package body Decls2 is -- new - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; -end Decls2; -@end example +@item +All forced-dependency elimination @example -with Decls2; -package Utils is - procedure Put_Val (Arg : Decls2.My_Int); -end Utils; +remove switch -f @end example -@example -with Ada.Text_IO; use Ada.Text_IO; -package body Utils is - procedure Put_Val (Arg : Decls2.My_Int) is - begin - Put_Line (Arg'Img); - end Put_Val; -end Utils; -@end example +This tactic is suggested in case editing the forced-elaboration-order file is +not an option. -@example -with Decls1; -procedure Main is -begin - Decls1.Lib_Task.Start; -end Main; -@end example +The programmer should remove binder switch @code{-f} from the binder +arguments, and rebind. @item -@emph{Declare the tasks} - -The original example uses a single task declaration for @code{Lib_Task}. An -explicit task type declaration and a properly placed task object could avoid -the dependencies that would otherwise cause an elaboration circularity. The -example can be rewritten as follows: +Multiple-circularities diagnostic @example -package Decls is - task type Lib_Task is -- new - entry Start; - end Lib_Task; - - type My_Int is new Integer; - - function Ident (M : My_Int) return My_Int; -end Decls; +diagnose all circularities (binder switch -d_C) @end example -@example -with Utils; -package body Decls is - task body Lib_Task is - begin - accept Start; - Utils.Put_Val (2); - end Lib_Task; - - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; -end Decls; -@end example +By default, the binder will diagnose only the highest-precedence circularity. +If the program contains multiple circularities, the binder will suggest the +use of binder switch @code{-d_C} in order to obtain the diagnostics of all +circularities. -@example -with Decls; -package Utils is - procedure Put_Val (Arg : Decls.My_Int); -end Utils; -@end example +The programmer should add binder switch @code{-d_C} to the binder +arguments, and rebind. +@end itemize -@example -with Ada.Text_IO; use Ada.Text_IO; -package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin - Put_Line (Arg'Img); - end Put_Val; -end Utils; -@end example +If none of the tactics suggested by the binder eliminate the elaboration +circularity, the programmer should consider using one of the legacy elaboration +models, in the following order: -@example -with Decls; -package Obj_Decls is -- new - Task_Obj : Decls.Lib_Task; -end Obj_Decls; -@end example -@example -with Obj_Decls; -procedure Main is -begin - Obj_Decls.Task_Obj.Start; -- new -end Main; -@end example +@itemize * @item -@emph{Use restriction No_Entry_Calls_In_Elaboration_Code} +Use the pre-20.x legacy elaboration-order model, with binder switch +@code{-H}. -The issue exhibited in the original example under this section revolves -around the body of @code{Lib_Task} blocking on an accept statement. There is -no rule to prevent elaboration code from performing entry calls, however in -practice this is highly unusual. In addition, the pattern of starting tasks -at elaboration time and then immediately blocking on accept or select -statements is quite common. - -If a programmer knows that elaboration code will not perform any entry -calls, then the programmer can indicate that the static model should not -process the remainder of a task body once an accept or select statement has -been encountered. This behavior can be specified by a configuration pragma: +@item +Use both pre-18.x and pre-20.x legacy elaboration models, with compiler +switch @code{-gnatH} and binder switch @code{-H}. -@example -pragma Restrictions (No_Entry_Calls_In_Elaboration_Code); -@end example +@item +Use the relaxed static-elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ} and binder switch @code{-H}. -In addition to the change in behavior with respect to task bodies, the -static model will verify that no entry calls take place at elaboration time. +@item +Use the relaxed dynamic-elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ} @code{-gnatE} and binder switch +@code{-H}. @end itemize -@node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Task Issues,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{247}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{248} +@node Elaboration-related Compiler Switches,Summary of Procedures for Elaboration Control,Resolving Elaboration Circularities,Elaboration Order Handling in GNAT +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-related-compiler-switches}@anchor{242} @section Elaboration-related Compiler Switches @@ -28801,7 +28679,7 @@ the elaboration order chosen by the binder. Dynamic elaboration checking mode enabled -When this switch is in effect, GNAT activates the dynamic elaboration model. +When this switch is in effect, GNAT activates the dynamic model. @end table @geindex -gnatel (gnat) @@ -28813,6 +28691,10 @@ When this switch is in effect, GNAT activates the dynamic elaboration model. Turn on info messages on generated Elaborate[_All] pragmas +This switch is only applicable to the pre-20.x legacy elaboration models. +The post-20.x elaboration model no longer relies on implicitly generated +@code{Elaborate} and @code{Elaborate_All} pragmas to order units. + When this switch is in effect, GNAT will emit the following supplementary information depending on the elaboration model in effect. @@ -28828,7 +28710,7 @@ all library-level scenarios within the partition. @item @emph{Static model} -GNAT will indicate all scenarios executed during elaboration. In addition, +GNAT will indicate all scenarios invoked during elaboration. In addition, it will provide detailed traceback when an implicit @code{Elaborate} or @code{Elaborate_All} pragma is generated. @@ -28962,7 +28844,7 @@ checks. The example above will still fail at run time with an ABE. @end table @node Summary of Procedures for Elaboration Control,Inspecting the Chosen Elaboration Order,Elaboration-related Compiler Switches,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{249}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id16}@anchor{24a} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{243}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{244} @section Summary of Procedures for Elaboration Control @@ -28990,13 +28872,8 @@ as their origins. Elaboration warnings are enabled with compiler switch @code{-gnatwl}. @item -Use switch @code{-gnatel} to obtain messages on generated implicit -@code{Elaborate} and @code{Elaborate_All} pragmas. The trace information could -indicate why a server unit must be elaborated prior to a client unit. - -@item -If the warnings produced by the static model indicate that a task is -involved, consider the options in section @ref{245,,Resolving Task Issues}. +Cosider the tactics given in the suggestions section of the circularity +diagnostic. @item If none of the steps outlined above resolve the circularity, use a more @@ -29006,28 +28883,26 @@ permissive elaboration model, in the following order: @itemize - @item -Use the dynamic elaboration model, with compiler switch @code{-gnatE}. +Use the pre-20.x legacy elaboration-order model, with binder switch +@code{-H}. @item -Use the legacy static elaboration model, with compiler switch -@code{-gnatH}. +Use both pre-18.x and pre-20.x legacy elaboration models, with compiler +switch @code{-gnatH} and binder switch @code{-H}. @item -Use the legacy dynamic elaboration model, with compiler switches -@code{-gnatH} @code{-gnatE}. +Use the relaxed static elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ} and binder switch @code{-H}. @item -Use the relaxed legacy static elaboration model, with compiler switches -@code{-gnatH} @code{-gnatJ}. - -@item -Use the relaxed legacy dynamic elaboration model, with compiler switches -@code{-gnatH} @code{-gnatJ} @code{-gnatE}. +Use the relaxed dynamic elaboration model, with compiler switches +@code{-gnatH} @code{-gnatJ} @code{-gnatE} and binder switch +@code{-H}. @end itemize @end itemize @node Inspecting the Chosen Elaboration Order,,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT -@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{24b}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id17}@anchor{24c} +@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat inspecting-the-chosen-elaboration-order}@anchor{246} @section Inspecting the Chosen Elaboration Order @@ -29037,6 +28912,8 @@ elaboration order appears as a sequence of calls to @code{Elab_Body} and @code{Elab_Spec}, interspersed with assignments to @cite{Exxx} which indicates that a particular unit is elaborated. For example: +@quotation + @example System.Soft_Links'Elab_Body; E14 := True; @@ -29072,10 +28949,13 @@ Ada.Text_Io'Elab_Spec; Ada.Text_Io'Elab_Body; E07 := True; @end example +@end quotation Note also binder switch @code{-l}, which outputs the chosen elaboration order and provides a more readable form of the above: +@quotation + @example ada (spec) interfaces (spec) @@ -29162,9 +29042,10 @@ ada.text_io (body) text_io (spec) gdbstr (body) @end example +@end quotation @node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top -@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{24d}@anchor{gnat_ugn/inline_assembler id1}@anchor{24e} +@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{247}@anchor{gnat_ugn/inline_assembler id1}@anchor{248} @chapter Inline Assembler @@ -29223,7 +29104,7 @@ and with assembly language programming. @end menu @node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler -@anchor{gnat_ugn/inline_assembler id2}@anchor{24f}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{250} +@anchor{gnat_ugn/inline_assembler id2}@anchor{249}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{24a} @section Basic Assembler Syntax @@ -29339,7 +29220,7 @@ Intel: Destination first; for example @code{mov eax, 4}@w{ } @node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler -@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{251}@anchor{gnat_ugn/inline_assembler id3}@anchor{252} +@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{24b}@anchor{gnat_ugn/inline_assembler id3}@anchor{24c} @section A Simple Example of Inline Assembler @@ -29488,7 +29369,7 @@ If there are no errors, @code{as} will generate an object file @code{nothing.out}. @node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id4}@anchor{253}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{254} +@anchor{gnat_ugn/inline_assembler id4}@anchor{24d}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{24e} @section Output Variables in Inline Assembler @@ -29855,7 +29736,7 @@ end Get_Flags_3; @end quotation @node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id5}@anchor{255}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{256} +@anchor{gnat_ugn/inline_assembler id5}@anchor{24f}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{250} @section Input Variables in Inline Assembler @@ -29944,7 +29825,7 @@ _increment__incr.1: @end quotation @node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler -@anchor{gnat_ugn/inline_assembler id6}@anchor{257}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{258} +@anchor{gnat_ugn/inline_assembler id6}@anchor{251}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{252} @section Inlining Inline Assembler Code @@ -30015,7 +29896,7 @@ movl %esi,%eax thus saving the overhead of stack frame setup and an out-of-line call. @node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler -@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{259}@anchor{gnat_ugn/inline_assembler id7}@anchor{25a} +@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{253}@anchor{gnat_ugn/inline_assembler id7}@anchor{254} @section Other @code{Asm} Functionality @@ -30030,7 +29911,7 @@ and @code{Volatile}, which inhibits unwanted optimizations. @end menu @node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{25b}@anchor{gnat_ugn/inline_assembler id8}@anchor{25c} +@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{255}@anchor{gnat_ugn/inline_assembler id8}@anchor{256} @subsection The @code{Clobber} Parameter @@ -30094,7 +29975,7 @@ Use 'register' name @code{memory} if you changed a memory location @end itemize @node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality -@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{25d}@anchor{gnat_ugn/inline_assembler id9}@anchor{25e} +@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{257}@anchor{gnat_ugn/inline_assembler id9}@anchor{258} @subsection The @code{Volatile} Parameter @@ -30130,7 +30011,7 @@ to @code{True} only if the compiler's optimizations have created problems. @node GNU Free Documentation License,Index,Inline Assembler,Top -@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{25f}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{260} +@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{259}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{25a} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 41541c3..a3b6a7e 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -26,7 +26,6 @@ with ALI; use ALI; with ALI.Util; use ALI.Util; with Bcheck; use Bcheck; -with Binde; use Binde; with Binderr; use Binderr; with Bindgen; use Bindgen; with Bindo; use Bindo; @@ -475,6 +474,17 @@ procedure Gnatbind is Mapping_File := new String'(Argv (4 .. Argv'Last)); + -- -minimal + + elsif Argv (2 .. Argv'Last) = "minimal" then + if not Is_Cross_Compiler then + Write_Line + ("gnatbind: -minimal not expected to be used on native " & + "platforms"); + end if; + + Opt.Minimal_Binder := True; + -- -Mname elsif Argv'Length >= 3 and then Argv (2) = 'M' then @@ -883,14 +893,7 @@ begin Elab_Order : Unit_Id_Table; begin - -- Use the invocation and library graph-based elaboration order - -- when switch -d_N (new bindo order) is in effect. - - if Debug_Flag_Underscore_NN then - Find_Elaboration_Order (Elab_Order, First_Main_Lib_File); - else - Find_Elab_Order (Elab_Order, First_Main_Lib_File); - end if; + Find_Elaboration_Order (Elab_Order, First_Main_Lib_File); if Errors_Detected = 0 and then not Check_Only then Gen_Output_File diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 5e5ede0..69462e9 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -459,7 +459,7 @@ procedure Gnatlink is when 'v' => - -- Support "double" verbose mode. Second -v + -- Support "double" verbose mode. Second -v -- gets sent to the linker and binder phases. if Verbose_Mode then @@ -2068,7 +2068,7 @@ begin end Link_Step; -- Only keep the binder output file and it's associated object - -- file if compiling with the -g option. These files are only + -- file if compiling with the -g option. These files are only -- useful if debugging. if not Debug_Flag_Present then diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index 1821b1b..c44e134 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -82,6 +82,7 @@ #ifdef __MINGW32__ #include <winsock2.h> #include <ws2tcpip.h> +#include <versionhelpers.h> #undef EACCES #define EACCES WSAEACCES diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 00f32e5..f7e830e 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -54,8 +54,14 @@ #endif #ifdef IN_RTS + +#ifdef STANDALONE +#include "runtime.h" +#else #include "tconfig.h" #include "tsystem.h" +#endif + #include <sys/stat.h> /* We don't have libiberty, so use malloc. */ @@ -463,6 +469,7 @@ void fake_linux_sigemptyset (sigset_t *set) void __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) { +#ifndef STANDALONE mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext; /* On the i386 and x86-64 architectures, stack checking is performed by @@ -513,6 +520,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) mcontext->arm_pc+=1; #endif #endif +#endif } #endif @@ -1725,7 +1733,7 @@ __gnat_install_handler (void) #include <iv.h> #endif -#if ((defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6)) || defined (__x86_64__)) && !defined(__RTP__) +#if ((defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6))) && !defined(__RTP__) #define VXWORKS_FORCE_GUARD_PAGE 1 #include <vmLib.h> extern size_t vxIntStackOverflowSize; diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index ab6d81d..0e52feb 100644 --- a/gcc/ada/initialize.c +++ b/gcc/ada/initialize.c @@ -41,8 +41,7 @@ #endif #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" +#include "runtime.h" /* We don't have libiberty, so use malloc. */ #define xmalloc(S) malloc (S) #define xrealloc(V,S) realloc (V,S) diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index b2038a6..5b7fefc 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1751,7 +1751,7 @@ package body Inline is -- occurrences of pragmas referencing the formals are removed since -- they have no meaning when the body is inlined and the formals are -- rewritten (the analysis of the non-inlined body will handle these - -- pragmas). A new internal name is associated with Body_To_Inline. + -- pragmas). A new internal name is associated with Body_To_Inline. ------------------------------ -- Generate_Subprogram_Body -- @@ -2481,8 +2481,7 @@ package body Inline is -- thunk generated for it. Replace a return statement with an assignment -- to the target of the call, with appropriate conversions if needed. - function Process_Formals_In_Aspects (N : Node_Id) - return Traverse_Result; + function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result; -- Because aspects are linked indirectly to the rest of the tree, -- replacement of formals appearing in aspect specifications must -- be performed in a separate pass, using an instantiation of the @@ -2832,10 +2831,11 @@ package body Inline is -- Process_Formals_In_Aspects -- -------------------------------- - function Process_Formals_In_Aspects (N : Node_Id) - return Traverse_Result + function Process_Formals_In_Aspects + (N : Node_Id) return Traverse_Result is A : Node_Id; + begin if Has_Aspects (N) then A := First (Aspect_Specifications (N)); @@ -2849,7 +2849,7 @@ package body Inline is end Process_Formals_In_Aspects; procedure Replace_Formals_In_Aspects is - new Traverse_Proc (Process_Formals_In_Aspects); + new Traverse_Proc (Process_Formals_In_Aspects); ------------------ -- Process_Sloc -- diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index ffd6a90..987afcb 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -59,65 +59,32 @@ with System.WCh_Con; use System.WCh_Con; package body Lib.Writ is ----------------------- - -- Local Subprograms -- + -- Local subprograms -- ----------------------- - function Column (IS_Id : Invocation_Signature_Id) return Nat; - pragma Inline (Column); - -- Obtain attribute Column of an invocation signature with id IS_Id - - function Extra (IR_Id : Invocation_Relation_Id) return Name_Id; - pragma Inline (Extra); - -- Obtain attribute Extra of an invocation relation with id IR_Id - - function Invoker - (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; - pragma Inline (Invoker); - -- Obtain attribute Invoker of an invocation relation with id IR_Id - - function Kind - (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind; - pragma Inline (Kind); - -- Obtain attribute Kind of an invocation construct with id IC_Id - - function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind; - pragma Inline (Kind); - -- Obtain attribute Kind of an invocation relation with id IR_Id - - function Line (IS_Id : Invocation_Signature_Id) return Nat; - pragma Inline (Line); - -- Obtain attribute Line of an invocation signature with id IS_Id - - function Locations (IS_Id : Invocation_Signature_Id) return Name_Id; - pragma Inline (Locations); - -- Obtain attribute Locations of an invocation signature with id IS_Id - - function Name (IS_Id : Invocation_Signature_Id) return Name_Id; - pragma Inline (Name); - -- Obtain attribute Name of an invocation signature with id IS_Id - - function Placement - (IC_Id : Invocation_Construct_Id) return Body_Placement_Kind; - pragma Inline (Placement); - -- Obtain attribute Placement of an invocation construct with id IC_Id - function Present (N_Id : Name_Id) return Boolean; pragma Inline (Present); -- Determine whether a name with id N_Id exists - function Scope (IS_Id : Invocation_Signature_Id) return Name_Id; - pragma Inline (Scope); - -- Obtain attribute Scope of an invocation signature with id IS_Id + procedure Write_Invocation_Construct (IC_Id : Invocation_Construct_Id); + pragma Inline (Write_Invocation_Construct); + -- Write invocation construct IC_Id to the ALI file + + procedure Write_Invocation_Graph; + pragma Inline (Write_Invocation_Graph); + -- Write out the invocation graph - function Signature - (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id; - pragma Inline (Signature); - -- Obtain attribute Signature of an invocation construct with id IC_Id + procedure Write_Invocation_Graph_Attributes; + pragma Inline (Write_Invocation_Graph_Attributes); + -- Write out the attributes of the invocation graph - function Target - (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id; - pragma Inline (Target); - -- Obtain attribute Target of an invocation relation with id IR_Id + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id); + pragma Inline (Write_Invocation_Relation); + -- Write invocation relation IR_Id to the ALI file + + procedure Write_Invocation_Signature (IS_Id : Invocation_Signature_Id); + pragma Inline (Write_Invocation_Signature); + -- Write invocation signature IS_Id to the ALI file procedure Write_Unit_Name (N : Node_Id); -- Used to write out the unit name for R (pragma Restriction) lines @@ -161,16 +128,6 @@ package body Lib.Writ is OA_Setting => 'O'); end Add_Preprocessing_Dependency; - ------------ - -- Column -- - ------------ - - function Column (IS_Id : Invocation_Signature_Id) return Nat is - begin - pragma Assert (Present (IS_Id)); - return Invocation_Signatures.Table (IS_Id).Column; - end Column; - ------------------------------ -- Ensure_System_Dependency -- ------------------------------ @@ -186,7 +143,7 @@ package body Lib.Writ is -- Nothing to do if we already compiled System for Unum in Units.First .. Last_Unit loop - if Units.Table (Unum).Source_Index = System_Source_File_Index then + if Source_Index (Unum) = System_Source_File_Index then return; end if; end loop; @@ -252,92 +209,6 @@ package body Lib.Writ is end; end Ensure_System_Dependency; - ----------- - -- Extra -- - ----------- - - function Extra (IR_Id : Invocation_Relation_Id) return Name_Id is - begin - pragma Assert (Present (IR_Id)); - return Invocation_Relations.Table (IR_Id).Extra; - end Extra; - - ------------- - -- Invoker -- - ------------- - - function Invoker - (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id - is - begin - pragma Assert (Present (IR_Id)); - return Invocation_Relations.Table (IR_Id).Invoker; - end Invoker; - - ---------- - -- Kind -- - ---------- - - function Kind - (IC_Id : Invocation_Construct_Id) return Invocation_Construct_Kind - is - begin - pragma Assert (Present (IC_Id)); - return Invocation_Constructs.Table (IC_Id).Kind; - end Kind; - - ---------- - -- Kind -- - ---------- - - function Kind (IR_Id : Invocation_Relation_Id) return Invocation_Kind is - begin - pragma Assert (Present (IR_Id)); - return Invocation_Relations.Table (IR_Id).Kind; - end Kind; - - ---------- - -- Line -- - ---------- - - function Line (IS_Id : Invocation_Signature_Id) return Nat is - begin - pragma Assert (Present (IS_Id)); - return Invocation_Signatures.Table (IS_Id).Line; - end Line; - - --------------- - -- Locations -- - --------------- - - function Locations (IS_Id : Invocation_Signature_Id) return Name_Id is - begin - pragma Assert (Present (IS_Id)); - return Invocation_Signatures.Table (IS_Id).Locations; - end Locations; - - ---------- - -- Name -- - ---------- - - function Name (IS_Id : Invocation_Signature_Id) return Name_Id is - begin - pragma Assert (Present (IS_Id)); - return Invocation_Signatures.Table (IS_Id).Name; - end Name; - - --------------- - -- Placement -- - --------------- - - function Placement - (IC_Id : Invocation_Construct_Id) return Body_Placement_Kind - is - begin - pragma Assert (Present (IC_Id)); - return Invocation_Constructs.Table (IC_Id).Placement; - end Placement; - ------------- -- Present -- ------------- @@ -347,40 +218,6 @@ package body Lib.Writ is return N_Id /= No_Name; end Present; - ----------- - -- Scope -- - ----------- - - function Scope (IS_Id : Invocation_Signature_Id) return Name_Id is - begin - pragma Assert (Present (IS_Id)); - return Invocation_Signatures.Table (IS_Id).Scope; - end Scope; - - --------------- - -- Signature -- - --------------- - - function Signature - (IC_Id : Invocation_Construct_Id) return Invocation_Signature_Id - is - begin - pragma Assert (Present (IC_Id)); - return Invocation_Constructs.Table (IC_Id).Signature; - end Signature; - - ------------ - -- Target -- - ------------ - - function Target - (IR_Id : Invocation_Relation_Id) return Invocation_Signature_Id - is - begin - pragma Assert (Present (IR_Id)); - return Invocation_Relations.Table (IR_Id).Target; - end Target; - --------------- -- Write_ALI -- --------------- @@ -441,9 +278,6 @@ package body Lib.Writ is -- this file (using Scan_ALI) and returns True. If no file exists, -- or the file is not up to date, then False is returned. - procedure Write_Invocation_Graph; - -- Write out the invocation graph - procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); -- Write out the library information for one unit for which code is -- generated (includes unit line and with lines). @@ -597,7 +431,7 @@ package body Lib.Writ is Id := First_Sdep_Entry; for J in 1 .. Num_Sdep loop - Sind := Units.Table (Sdep_Table (J)).Source_Index; + Sind := Source_Index (Sdep_Table (J)); while Sdep.Table (Id).Sfile /= File_Name (Sind) loop if Id = Sdep.Last then @@ -633,175 +467,6 @@ package body Lib.Writ is end Update_Tables_From_ALI_File; ---------------------------- - -- Write_Invocation_Graph -- - ---------------------------- - - procedure Write_Invocation_Graph is - procedure Write_Invocation_Construct - (IC_Id : Invocation_Construct_Id); - pragma Inline (Write_Invocation_Construct); - -- Write invocation construct IC_Id to the ALI file - - procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id); - pragma Inline (Write_Invocation_Relation); - -- Write invocation relation IR_Id to the ALI file - - procedure Write_Invocation_Signature - (IS_Id : Invocation_Signature_Id); - pragma Inline (Write_Invocation_Signature); - -- Write invocation signature IS_Id to the ALI file - - -------------------------------- - -- Write_Invocation_Construct -- - -------------------------------- - - procedure Write_Invocation_Construct - (IC_Id : Invocation_Construct_Id) - is - begin - -- G header - - Write_Info_Initiate ('G'); - Write_Info_Char (' '); - - -- line-kind - - Write_Info_Char - (Invocation_Graph_Line_Kind_To_Code (Invocation_Construct_Line)); - Write_Info_Char (' '); - - -- construct-kind - - Write_Info_Char (Invocation_Construct_Kind_To_Code (Kind (IC_Id))); - Write_Info_Char (' '); - - -- construct-body-placement - - Write_Info_Char (Body_Placement_Kind_To_Code (Placement (IC_Id))); - Write_Info_Char (' '); - - -- construct-signature - - Write_Invocation_Signature (Signature (IC_Id)); - Write_Info_EOL; - end Write_Invocation_Construct; - - ------------------------------- - -- Write_Invocation_Relation -- - ------------------------------- - - procedure Write_Invocation_Relation - (IR_Id : Invocation_Relation_Id) - is - begin - -- G header - - Write_Info_Initiate ('G'); - Write_Info_Char (' '); - - -- line-kind - - Write_Info_Char - (Invocation_Graph_Line_Kind_To_Code (Invocation_Relation_Line)); - Write_Info_Char (' '); - - -- relation-kind - - Write_Info_Char (Invocation_Kind_To_Code (Kind (IR_Id))); - Write_Info_Char (' '); - - -- (extra-name | "none") - - if Present (Extra (IR_Id)) then - Write_Info_Name (Extra (IR_Id)); - else - Write_Info_Str ("none"); - end if; - - Write_Info_Char (' '); - - -- invoker-signature - - Write_Invocation_Signature (Invoker (IR_Id)); - Write_Info_Char (' '); - - -- target-signature - - Write_Invocation_Signature (Target (IR_Id)); - - Write_Info_EOL; - end Write_Invocation_Relation; - - -------------------------------- - -- Write_Invocation_Signature -- - -------------------------------- - - procedure Write_Invocation_Signature - (IS_Id : Invocation_Signature_Id) - is - begin - -- [ - - Write_Info_Char ('['); - - -- name - - Write_Info_Name (Name (IS_Id)); - Write_Info_Char (' '); - - -- scope - - Write_Info_Name (Scope (IS_Id)); - Write_Info_Char (' '); - - -- line - - Write_Info_Nat (Line (IS_Id)); - Write_Info_Char (' '); - - -- column - - Write_Info_Nat (Column (IS_Id)); - Write_Info_Char (' '); - - -- (locations | "none") - - if Present (Locations (IS_Id)) then - Write_Info_Name (Locations (IS_Id)); - else - Write_Info_Str ("none"); - end if; - - -- ] - - Write_Info_Char (']'); - end Write_Invocation_Signature; - - -- Start of processing for Write_Invocation_Graph - - begin - -- First write out all invocation constructs declared within the - -- current unit. This ensures that when this invocation is read, - -- the invocation constructs are materialized before they are - -- referenced by invocation relations. - - for IC_Id in Invocation_Constructs.First .. - Invocation_Constructs.Last - loop - Write_Invocation_Construct (IC_Id); - end loop; - - -- Write out all invocation relations that originate from invocation - -- constructs delared in the current unit. - - for IR_Id in Invocation_Relations.First .. - Invocation_Relations.Last - loop - Write_Invocation_Relation (IR_Id); - end loop; - end Write_Invocation_Graph; - - ---------------------------- -- Write_Unit_Information -- ---------------------------- @@ -1416,7 +1081,7 @@ package body Lib.Writ is begin -- We never write an ALI file if the original operating mode was - -- syntax-only (-gnats switch used in compiler invocation line) + -- syntax-only (-gnats switch used in compiler invocation line). if Original_Operating_Mode = Check_Syntax then return; @@ -1898,7 +1563,7 @@ package body Lib.Writ is for J in 1 .. Num_Sdep loop Unum := Sdep_Table (J); Units.Table (Unum).Dependency_Num := J; - Sind := Units.Table (Unum).Source_Index; + Sind := Source_Index (Unum); Write_Info_Initiate ('D'); Write_Info_Char (' '); @@ -2010,6 +1675,179 @@ package body Lib.Writ is Close_Output_Library_Info; end Write_ALI; + -------------------------------- + -- Write_Invocation_Construct -- + -------------------------------- + + procedure Write_Invocation_Construct (IC_Id : Invocation_Construct_Id) is + begin + -- G header + + Write_Info_Initiate ('G'); + Write_Info_Char (' '); + + -- line-kind + + Write_Info_Char + (Invocation_Graph_Line_Kind_To_Code (Invocation_Construct_Line)); + Write_Info_Char (' '); + + -- construct-kind + + Write_Info_Char (Invocation_Construct_Kind_To_Code (Kind (IC_Id))); + Write_Info_Char (' '); + + -- construct-spec-placement + + Write_Info_Char + (Declaration_Placement_Kind_To_Code (Spec_Placement (IC_Id))); + Write_Info_Char (' '); + + -- construct-body-placement + + Write_Info_Char + (Declaration_Placement_Kind_To_Code (Body_Placement (IC_Id))); + Write_Info_Char (' '); + + -- construct-signature + + Write_Invocation_Signature (Signature (IC_Id)); + Write_Info_EOL; + end Write_Invocation_Construct; + + --------------------------------------- + -- Write_Invocation_Graph_Attributes -- + --------------------------------------- + + procedure Write_Invocation_Graph_Attributes is + begin + -- G header + + Write_Info_Initiate ('G'); + Write_Info_Char (' '); + + -- line-kind + + Write_Info_Char + (Invocation_Graph_Line_Kind_To_Code + (Invocation_Graph_Attributes_Line)); + Write_Info_Char (' '); + + -- encoding-kind + + Write_Info_Char + (Invocation_Graph_Encoding_Kind_To_Code (Invocation_Graph_Encoding)); + Write_Info_EOL; + end Write_Invocation_Graph_Attributes; + + ---------------------------- + -- Write_Invocation_Graph -- + ---------------------------- + + procedure Write_Invocation_Graph is + begin + Write_Invocation_Graph_Attributes; + + -- First write out all invocation constructs declared within the current + -- unit. This ensures that when this invocation is read, the invocation + -- constructs are materialized before they are referenced by invocation + -- relations. + + For_Each_Invocation_Construct (Write_Invocation_Construct'Access); + + -- Write out all invocation relations that originate from invocation + -- constructs delared in the current unit. + + For_Each_Invocation_Relation (Write_Invocation_Relation'Access); + end Write_Invocation_Graph; + + ------------------------------- + -- Write_Invocation_Relation -- + ------------------------------- + + procedure Write_Invocation_Relation (IR_Id : Invocation_Relation_Id) is + begin + -- G header + + Write_Info_Initiate ('G'); + Write_Info_Char (' '); + + -- line-kind + + Write_Info_Char + (Invocation_Graph_Line_Kind_To_Code (Invocation_Relation_Line)); + Write_Info_Char (' '); + + -- relation-kind + + Write_Info_Char (Invocation_Kind_To_Code (Kind (IR_Id))); + Write_Info_Char (' '); + + -- (extra-name | "none") + + if Present (Extra (IR_Id)) then + Write_Info_Name (Extra (IR_Id)); + else + Write_Info_Str ("none"); + end if; + + Write_Info_Char (' '); + + -- invoker-signature + + Write_Invocation_Signature (Invoker (IR_Id)); + Write_Info_Char (' '); + + -- target-signature + + Write_Invocation_Signature (Target (IR_Id)); + + Write_Info_EOL; + end Write_Invocation_Relation; + + -------------------------------- + -- Write_Invocation_Signature -- + -------------------------------- + + procedure Write_Invocation_Signature (IS_Id : Invocation_Signature_Id) is + begin + -- [ + + Write_Info_Char ('['); + + -- name + + Write_Info_Name (Name (IS_Id)); + Write_Info_Char (' '); + + -- scope + + Write_Info_Name (Scope (IS_Id)); + Write_Info_Char (' '); + + -- line + + Write_Info_Nat (Line (IS_Id)); + Write_Info_Char (' '); + + -- column + + Write_Info_Nat (Column (IS_Id)); + Write_Info_Char (' '); + + -- (locations | "none") + + if Present (Locations (IS_Id)) then + Write_Info_Name (Locations (IS_Id)); + else + Write_Info_Str ("none"); + end if; + + -- ] + + Write_Info_Char (']'); + end Write_Invocation_Signature; + --------------------- -- Write_Unit_Name -- --------------------- diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index c17233a..7248a61 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -880,18 +880,32 @@ package Lib.Writ is -- locations of all instances where the initial declaration of the -- construct appears. -- + -- When the line-kind denotes invocation graph attributes, line-attributes + -- are set as follows: + -- + -- encoding-kind + -- + -- Attribute encoding-kind is a Character which specifies the encoding + -- kind used when collecting invocation constructs and relations. Table + -- ALI.Invocation_Graph_Encoding_Codes lists all legal values. + -- -- When the line-kind denotes an invocation construct, line-attributes are -- set as follows: -- - -- construct-kind construct-body-placement construct-signature + -- construct-kind construct-spec-placement construct-body-placement + -- construct-signature -- -- Attribute construct-kind is a Character which denotes the nature of -- the construct. Table ALI.Invocation_Construct_Codes lists all legal -- values. -- + -- Attribute construct-spec-placement is a Character which denotes the + -- placement of the construct's spec within the unit. All legal values + -- are listed in table ALI.Spec_And_Body_Placement_Codes. + -- -- Attribute construct-body-placement is a Character which denotes the -- placement of the construct's body within the unit. All legal values - -- are listed in table ALI.Body_Placement_Codes. + -- are listed in table ALI.Spec_And_Body_Placement_Codes. -- -- Attribute construct-signature is the invocation signature of the -- construct. @@ -925,7 +939,7 @@ package Lib.Writ is -- Postcondition_Verification - related routine -- Protected_Entry_Call - not present -- Protected_Subprogram_Call - not present - -- Task_Activation - related task object + -- Task_Activation - not present -- Task_Entry_Call - not present -- Type_Initialization - related type -- diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index 36aaefb..0ad7044 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -298,6 +298,7 @@ package body SPARK_Specific is Set_Ekind (Heap, E_Variable); Set_Is_Internal (Heap, True); + Set_Etype (Heap, Standard_Void_Type); Set_Scope (Heap, Standard_Standard); Set_Has_Fully_Qualified_Name (Heap); end Create_Heap; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index c6c11c1..504120e 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -993,7 +993,7 @@ private -- clause. The First entry is the main unit. The second entry, if present -- is a unit on which the first unit depends, etc. This stack is used to -- generate error messages showing the dependency chain if a file is not - -- found, or whether a true circular dependency exists. The Load_Unit + -- found, or whether a true circular dependency exists. The Load_Unit -- function makes an entry in this table when it is called, and removes -- the entry just before it returns. diff --git a/gcc/ada/libgnarl/a-taside.ads b/gcc/ada/libgnarl/a-taside.ads index 4939d1e..6bdb252 100644 --- a/gcc/ada/libgnarl/a-taside.ads +++ b/gcc/ada/libgnarl/a-taside.ads @@ -33,6 +33,12 @@ -- -- ------------------------------------------------------------------------------ +-- 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 System; with System.Tasking; @@ -67,17 +73,20 @@ is pragma Inline (Environment_Task); procedure Abort_Task (T : Task_Id) with + Pre => T /= Null_Task_Id, Global => null; pragma Inline (Abort_Task); -- Note: parameter is mode IN, not IN OUT, per AI-00101 function Is_Terminated (T : Task_Id) return Boolean with Volatile_Function, + Pre => T /= Null_Task_Id, Global => Tasking_State; pragma Inline (Is_Terminated); function Is_Callable (T : Task_Id) return Boolean with Volatile_Function, + Pre => T /= Null_Task_Id, Global => Tasking_State; pragma Inline (Is_Callable); diff --git a/gcc/ada/libgnarl/g-thread.adb b/gcc/ada/libgnarl/g-thread.adb index f4ce92e..ae61937 100644 --- a/gcc/ada/libgnarl/g-thread.adb +++ b/gcc/ada/libgnarl/g-thread.adb @@ -168,9 +168,14 @@ package body GNAT.Threads is ---------------- procedure Get_Thread (Id : Address; Thread : Address) is - Thr : constant Thread_Id_Ptr := To_Thread (Thread); begin - Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); + To_Thread (Thread).all := + Task_Primitives.Operations.Get_Thread_Id (To_Id (Id)); + end Get_Thread; + + procedure Get_Thread (Id : Task_Id; Thread : Address) is + begin + Get_Thread (To_Addr (Id), Thread); end Get_Thread; ---------------------- diff --git a/gcc/ada/libgnarl/g-thread.ads b/gcc/ada/libgnarl/g-thread.ads index ad4a075..8792e9a 100644 --- a/gcc/ada/libgnarl/g-thread.ads +++ b/gcc/ada/libgnarl/g-thread.ads @@ -129,9 +129,11 @@ package GNAT.Threads is procedure Get_Thread (Id : System.Address; Thread : System.Address); pragma Export (C, Get_Thread, "__gnat_get_thread"); + procedure Get_Thread + (Id : Ada.Task_Identification.Task_Id; Thread : System.Address); -- This procedure is used to retrieve the thread id of a given task. -- The value Id is the value that was passed to the thread code procedure - -- at activation time. + -- at activation time or a Task_Id. -- Thread is a pointer to a thread id that will be updated by this -- procedure. -- diff --git a/gcc/ada/libgnarl/s-linux.ads b/gcc/ada/libgnarl/s-linux.ads index 94c2ea1..4220fa0 100644 --- a/gcc/ada/libgnarl/s-linux.ads +++ b/gcc/ada/libgnarl/s-linux.ads @@ -82,7 +82,7 @@ package System.Linux is SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) SIGBUS : constant := 7; -- bus error diff --git a/gcc/ada/libgnarl/s-linux__alpha.ads b/gcc/ada/libgnarl/s-linux__alpha.ads index 18a1253..fea3746 100644 --- a/gcc/ada/libgnarl/s-linux__alpha.ads +++ b/gcc/ada/libgnarl/s-linux__alpha.ads @@ -82,7 +82,7 @@ package System.Linux is SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) SIGBUS : constant := 10; -- bus error diff --git a/gcc/ada/libgnarl/s-linux__android.ads b/gcc/ada/libgnarl/s-linux__android.ads index 914f08d..8d8a1f4 100644 --- a/gcc/ada/libgnarl/s-linux__android.ads +++ b/gcc/ada/libgnarl/s-linux__android.ads @@ -82,7 +82,7 @@ package System.Linux is SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) SIGBUS : constant := 7; -- bus error diff --git a/gcc/ada/libgnarl/s-linux__hppa.ads b/gcc/ada/libgnarl/s-linux__hppa.ads index bc7034a..feb21f6 100644 --- a/gcc/ada/libgnarl/s-linux__hppa.ads +++ b/gcc/ada/libgnarl/s-linux__hppa.ads @@ -82,7 +82,7 @@ package System.Linux is SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGEMT : constant := 7; -- EMT SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) diff --git a/gcc/ada/libgnarl/s-linux__mips.ads b/gcc/ada/libgnarl/s-linux__mips.ads index 0fa808f..6aea5a8 100644 --- a/gcc/ada/libgnarl/s-linux__mips.ads +++ b/gcc/ada/libgnarl/s-linux__mips.ads @@ -82,7 +82,7 @@ package System.Linux is SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGEMT : constant := 7; -- EMT SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) diff --git a/gcc/ada/libgnarl/s-linux__riscv.ads b/gcc/ada/libgnarl/s-linux__riscv.ads index 6151b29..61ccc3b 100644 --- a/gcc/ada/libgnarl/s-linux__riscv.ads +++ b/gcc/ada/libgnarl/s-linux__riscv.ads @@ -82,7 +82,7 @@ package System.Linux is SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGBUS : constant := 7; -- bus error SIGFPE : constant := 8; -- floating point exception SIGKILL : constant := 9; -- kill (cannot be caught or ignored) diff --git a/gcc/ada/libgnarl/s-linux__sparc.ads b/gcc/ada/libgnarl/s-linux__sparc.ads index de31105..e619890 100644 --- a/gcc/ada/libgnarl/s-linux__sparc.ads +++ b/gcc/ada/libgnarl/s-linux__sparc.ads @@ -81,7 +81,7 @@ package System.Linux is SIGQUIT : constant := 3; -- quit (ASCD FS) SIGILL : constant := 4; -- illegal instruction (not reset) SIGTRAP : constant := 5; -- trace trap (not reset) - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future SIGIOT : constant := 6; -- IOT instruction SIGEMT : constant := 7; -- EMT SIGFPE : constant := 8; -- floating point exception diff --git a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads index f46bbda..aa6c1a8 100644 --- a/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads +++ b/gcc/ada/libgnarl/s-osinte__kfreebsd-gnu.ads @@ -206,9 +206,8 @@ package System.OS_Interface is function nanosleep (rqtp, rmtp : access timespec) return int; pragma Import (C, nanosleep, "nanosleep"); - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; function clock_gettime (clock_id : clockid_t; @@ -607,9 +606,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - type pthread_attr_t is record detachstate : int; schedpolicy : int; diff --git a/gcc/ada/libgnarl/s-osinte__linux.ads b/gcc/ada/libgnarl/s-osinte__linux.ads index ba3b824..80cb2b2 100644 --- a/gcc/ada/libgnarl/s-osinte__linux.ads +++ b/gcc/ada/libgnarl/s-osinte__linux.ads @@ -46,10 +46,11 @@ with System.OS_Constants; package System.OS_Interface is pragma Preelaborate; - pragma Linker_Options ("-lpthread"); pragma Linker_Options ("-lrt"); -- Needed for clock_getres with glibc versions prior to 2.17 + pragma Linker_Options ("-lpthread"); + subtype int is Interfaces.C.int; subtype char is Interfaces.C.char; subtype short is Interfaces.C.short; diff --git a/gcc/ada/libgnarl/s-osinte__mingw.ads b/gcc/ada/libgnarl/s-osinte__mingw.ads index 2cf47b7..2a98664 100644 --- a/gcc/ada/libgnarl/s-osinte__mingw.ads +++ b/gcc/ada/libgnarl/s-osinte__mingw.ads @@ -369,7 +369,7 @@ private -- section for the resource. LockSemaphore : Win32.HANDLE; - SpinCount : Win32.DWORD; + SpinCount : Interfaces.C.size_t; end record; end System.OS_Interface; diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb index 2cdde01..580ca12 100644 --- a/gcc/ada/libgnat/a-cfhama.adb +++ b/gcc/ada/libgnat/a-cfhama.adb @@ -509,8 +509,11 @@ is procedure Free (HT : in out Map; X : Count_Type) is begin - HT.Nodes (X).Has_Element := False; - HT_Ops.Free (HT, X); + if X /= 0 then + pragma Assert (X <= HT.Capacity); + HT.Nodes (X).Has_Element := False; + HT_Ops.Free (HT, X); + end if; end Free; ---------------------- diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb index ae8ae12..8cc220c 100644 --- a/gcc/ada/libgnat/a-cfhase.adb +++ b/gcc/ada/libgnat/a-cfhase.adb @@ -760,8 +760,11 @@ is procedure Free (HT : in out Set; X : Count_Type) is begin - HT.Nodes (X).Has_Element := False; - HT_Ops.Free (HT, X); + if X /= 0 then + pragma Assert (X <= HT.Capacity); + HT.Nodes (X).Has_Element := False; + HT_Ops.Free (HT, X); + end if; end Free; ---------------------- diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb index f9675ab..c848ad8 100644 --- a/gcc/ada/libgnat/a-cofove.adb +++ b/gcc/ada/libgnat/a-cofove.adb @@ -26,7 +26,6 @@ ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; with System; use type System.Address; @@ -34,41 +33,10 @@ package body Ada.Containers.Formal_Vectors with SPARK_Mode => Off is - Growth_Factor : constant := 2; - -- When growing a container, multiply current capacity by this. Doubling - -- leads to amortized linear-time copying. - type Int is range System.Min_Int .. System.Max_Int; - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); - - type Maximal_Array_Ptr is access all Elements_Array (Array_Index) - with Storage_Size => 0; - type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) - with Storage_Size => 0; - - function Elems (Container : in out Vector) return Maximal_Array_Ptr; - function Elemsc - (Container : Vector) return Maximal_Array_Ptr_Const; - -- Returns a pointer to the Elements array currently in use -- either - -- Container.Elements_Ptr or a pointer to Container.Elements. We work with - -- pointers to a bogus array subtype that is constrained with the maximum - -- possible bounds. This means that the pointer is a thin pointer. This is - -- necessary because 'Unrestricted_Access doesn't work when it produces - -- access-to-unconstrained and is returned from a function. - -- - -- Note that this is dangerous: make sure calls to this use an indexed - -- component or slice that is within the bounds 1 .. Length (Container). - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type; - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - function Current_Capacity (Container : Vector) return Capacity_Range; - procedure Insert_Space (Container : in out Vector; Before : Extended_Index; @@ -89,7 +57,7 @@ is end if; for J in 1 .. Length (Left) loop - if Get_Element (Left, J) /= Get_Element (Right, J) then + if Left.Elements (J) /= Right.Elements (J) then return False; end if; end loop; @@ -148,7 +116,7 @@ is return; end if; - if Bounded and then Target.Capacity < LS then + if Target.Capacity < LS then raise Constraint_Error; end if; @@ -162,11 +130,7 @@ is function Capacity (Container : Vector) return Capacity_Range is begin - return - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); + return Container.Capacity; end Capacity; ----------- @@ -176,10 +140,6 @@ is procedure Clear (Container : in out Vector) is begin Container.Last := No_Index; - - -- Free element, note that this is OK if Elements_Ptr is null - - Free (Container.Elements_Ptr); end Clear; -------------- @@ -215,24 +175,11 @@ is end if; return Target : Vector (C) do - Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS); + Target.Elements (1 .. LS) := Source.Elements (1 .. LS); Target.Last := Source.Last; end return; end Copy; - ---------------------- - -- Current_Capacity -- - ---------------------- - - function Current_Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Length - else - Container.Elements_Ptr.all'Length); - end Current_Capacity; - ------------ -- Delete -- ------------ @@ -333,7 +280,7 @@ is -- so we just slide down to Index the elements that weren't deleted. declare - EA : Maximal_Array_Ptr renames Elems (Container); + EA : Elements_Array renames Container.Elements; Idx : constant Count_Type := EA'First + Off; begin EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); @@ -418,32 +365,10 @@ is II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Capacity_Range := Capacity_Range (II); begin - return Get_Element (Container, I); + return Container.Elements (I); end; end Element; - ----------- - -- Elems -- - ----------- - - function Elems (Container : in out Vector) return Maximal_Array_Ptr is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elems; - - function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elemsc; - ---------------- -- Find_Index -- ---------------- @@ -459,7 +384,7 @@ is begin K := Capacity_Range (Int (Index) - Int (No_Index)); for Indx in Index .. Last loop - if Get_Element (Container, K) = Item then + if Container.Elements (K) = Item then return Indx; end if; @@ -478,7 +403,7 @@ is if Is_Empty (Container) then raise Constraint_Error with "Container is empty"; else - return Get_Element (Container, 1); + return Container.Elements (1); end if; end First_Element; @@ -622,7 +547,7 @@ is begin for Position in 1 .. Length (Container) loop - R := M.Add (R, Elemsc (Container) (Position)); + R := M.Add (R, Container.Elements (Position)); end loop; return R; @@ -684,8 +609,8 @@ is begin for J in 1 .. L - 1 loop - if Get_Element (Container, J + 1) < - Get_Element (Container, J) + if Container.Elements (J + 1) < + Container.Elements (J) then return False; end if; @@ -712,7 +637,7 @@ is if Container.Last <= Index_Type'First then return; else - Sort (Elems (Container) (1 .. Len)); + Sort (Container.Elements (1 .. Len)); end if; end Sort; @@ -744,16 +669,6 @@ is New_Length : constant Count_Type := I + Length (Source); begin - if not Bounded - and then Current_Capacity (Target) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Target, - Capacity_Range'Max - (Current_Capacity (Target) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then Target.Last := No_Index + Index_Type'Base (New_Length); @@ -764,8 +679,8 @@ is end; declare - TA : Maximal_Array_Ptr renames Elems (Target); - SA : Maximal_Array_Ptr renames Elems (Source); + TA : Elements_Array renames Target.Elements; + SA : Elements_Array renames Source.Elements; begin J := Length (Target); @@ -793,18 +708,6 @@ is end Generic_Sorting; ----------------- - -- Get_Element -- - ----------------- - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type - is - begin - return Elemsc (Container) (Position); - end Get_Element; - - ----------------- -- Has_Element -- ----------------- @@ -844,7 +747,7 @@ is J := To_Array_Index (Before); - Elems (Container) (J .. J - 1 + Count) := (others => New_Item); + Container.Elements (J .. J - 1 + Count) := (others => New_Item); end Insert; procedure Insert @@ -876,7 +779,7 @@ is B := To_Array_Index (Before); - Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N); + Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N); end Insert; ------------------ @@ -1053,19 +956,8 @@ is J := To_Array_Index (Before); - -- Increase the capacity of container if needed - - if not Bounded - and then Current_Capacity (Container) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Container, - Capacity_Range'Max (Current_Capacity (Container) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - declare - EA : Maximal_Array_Ptr renames Elems (Container); + EA : Elements_Array renames Container.Elements; begin if Before <= Container.Last then @@ -1105,7 +997,7 @@ is if Is_Empty (Container) then raise Constraint_Error with "Container is empty"; else - return Get_Element (Container, Length (Container)); + return Container.Elements (Length (Container)); end if; end Last_Element; @@ -1143,7 +1035,7 @@ is return; end if; - if Bounded and then Target.Capacity < LS then + if Target.Capacity < LS then raise Constraint_Error; end if; @@ -1194,7 +1086,7 @@ is I : constant Capacity_Range := Capacity_Range (II); begin - Elems (Container) (I) := New_Item; + Container.Elements (I) := New_Item; end; end Replace_Element; @@ -1207,24 +1099,8 @@ is Capacity : Capacity_Range) is begin - if Bounded then - if Capacity > Container.Capacity then - raise Constraint_Error with "Capacity is out of range"; - end if; - - else - if Capacity > Formal_Vectors.Current_Capacity (Container) then - declare - New_Elements : constant Elements_Array_Ptr := - new Elements_Array (1 .. Capacity); - L : constant Capacity_Range := Length (Container); - - begin - New_Elements (1 .. L) := Elemsc (Container) (1 .. L); - Free (Container.Elements_Ptr); - Container.Elements_Ptr := New_Elements; - end; - end if; + if Capacity > Container.Capacity then + raise Constraint_Error with "Capacity is out of range"; end if; end Reserve_Capacity; @@ -1241,7 +1117,7 @@ is declare I, J : Capacity_Range; E : Elements_Array renames - Elems (Container) (1 .. Length (Container)); + Container.Elements (1 .. Length (Container)); begin I := 1; @@ -1282,7 +1158,7 @@ is K := Capacity_Range (Int (Last) - Int (No_Index)); for Indx in reverse Index_Type'First .. Last loop - if Get_Element (Container, K) = Item then + if Container.Elements (K) = Item then return Indx; end if; @@ -1318,8 +1194,8 @@ is II : constant Int'Base := Int (I) - Int (No_Index); JJ : constant Int'Base := Int (J) - Int (No_Index); - EI : Element_Type renames Elems (Container) (Capacity_Range (II)); - EJ : Element_Type renames Elems (Container) (Capacity_Range (JJ)); + EI : Element_Type renames Container.Elements (Capacity_Range (II)); + EJ : Element_Type renames Container.Elements (Capacity_Range (JJ)); EI_Copy : constant Element_Type := EI; @@ -1388,10 +1264,9 @@ is Last := Index_Type (Last_As_Int); return - (Capacity => Length, - Last => Last, - Elements_Ptr => <>, - Elements => (others => New_Item)); + (Capacity => Length, + Last => Last, + Elements => (others => New_Item)); end; end To_Vector; diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads index 635ef48..5b62664 100644 --- a/gcc/ada/libgnat/a-cofove.ads +++ b/gcc/ada/libgnat/a-cofove.ads @@ -40,12 +40,6 @@ with Ada.Containers.Functional_Vectors; generic type Index_Type is range <>; type Element_Type is private; - - Bounded : Boolean := True; - -- If True, the containers are bounded; the initial capacity is the maximum - -- size, and heap allocation will be avoided. If False, the containers can - -- grow via heap allocation. - package Ada.Containers.Formal_Vectors with SPARK_Mode is @@ -73,17 +67,8 @@ is subtype Capacity_Range is Count_Type range 0 .. Last_Count; - type Vector (Capacity : Capacity_Range) is limited private with + type Vector (Capacity : Capacity_Range) is private with Default_Initial_Condition => Is_Empty (Vector); - -- In the bounded case, Capacity is the capacity of the container, which - -- never changes. In the unbounded case, Capacity is the initial capacity - -- of the container, and operations such as Reserve_Capacity and Append can - -- increase the capacity. The capacity never shrinks, except in the case of - -- Clear. - -- - -- Note that all objects of type Vector are constrained, including in the - -- unbounded case; you can't assign from one object to another if the - -- Capacity is different. function Length (Container : Vector) return Capacity_Range with Global => null, @@ -220,11 +205,7 @@ is function Capacity (Container : Vector) return Capacity_Range with Global => null, Post => - Capacity'Result = - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); + Capacity'Result = Container.Capacity; pragma Annotate (GNATprove, Inline_For_Proof, Capacity); procedure Reserve_Capacity @@ -232,7 +213,7 @@ is Capacity : Capacity_Range) with Global => null, - Pre => (if Bounded then Capacity <= Container.Capacity), + Pre => Capacity <= Container.Capacity, Post => Model (Container) = Model (Container)'Old; function Is_Empty (Container : Vector) return Boolean with @@ -242,13 +223,10 @@ is procedure Clear (Container : in out Vector) with Global => null, Post => Length (Container) = 0; - -- Note that this reclaims storage in the unbounded case. You need to call - -- this before a container goes out of scope in order to avoid storage - -- leaks. In addition, "X := ..." can leak unless you Clear(X) first. procedure Assign (Target : in out Vector; Source : Vector) with Global => null, - Pre => (if Bounded then Length (Source) <= Target.Capacity), + Pre => Length (Source) <= Target.Capacity, Post => Model (Target) = Model (Source); function Copy @@ -256,7 +234,7 @@ is Capacity : Capacity_Range := 0) return Vector with Global => null, - Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)), + Pre => (Capacity = 0 or Length (Source) <= Capacity), Post => Model (Copy'Result) = Model (Source) and (if Capacity = 0 then @@ -267,7 +245,7 @@ is procedure Move (Target : in out Vector; Source : in out Vector) with Global => null, - Pre => (if Bounded then Length (Source) <= Capacity (Target)), + Pre => Length (Source) <= Capacity (Target), Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; function Element @@ -894,30 +872,11 @@ private type Elements_Array is array (Array_Index range <>) of Element_Type; function "=" (L, R : Elements_Array) return Boolean is abstract; - type Elements_Array_Ptr is access all Elements_Array; - - type Vector (Capacity : Capacity_Range) is limited record - - -- In the bounded case, the elements are stored in Elements. In the - -- unbounded case, the elements are initially stored in Elements, until - -- we run out of room, then we switch to Elements_Ptr. - - Last : Extended_Index := No_Index; - Elements_Ptr : Elements_Array_Ptr := null; - Elements : aliased Elements_Array (1 .. Capacity); + type Vector (Capacity : Capacity_Range) is record + Last : Extended_Index := No_Index; + Elements : Elements_Array (1 .. Capacity); end record; - -- The primary reason Vector is limited is that in the unbounded case, once - -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will - -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr, - -- so for example "Append (X, ...);" will modify BOTH X and Y. That would - -- allow SPARK to "prove" things that are false. We could fix that by - -- making Vector a controlled type, and override Adjust to make a deep - -- copy, but finalization is not allowed in SPARK. - -- - -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not - -- allowed on Vectors. - function Empty_Vector return Vector is ((Capacity => 0, others => <>)); diff --git a/gcc/ada/libgnat/a-strbou.ads b/gcc/ada/libgnat/a-strbou.ads index f525ccf..ae61b86 100644 --- a/gcc/ada/libgnat/a-strbou.ads +++ b/gcc/ada/libgnat/a-strbou.ads @@ -33,6 +33,12 @@ -- -- ------------------------------------------------------------------------------ +-- 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; with Ada.Strings.Superbounded; @@ -43,7 +49,9 @@ package Ada.Strings.Bounded is Max : Positive; -- Maximum length of a Bounded_String - package Generic_Bounded_Length is + package Generic_Bounded_Length with + Initial_Condition => Length (Null_Bounded_String) = 0 + is Max_Length : constant Positive := Max; @@ -54,7 +62,8 @@ package Ada.Strings.Bounded is subtype Length_Range is Natural range 0 .. Max_Length; - function Length (Source : Bounded_String) return Length_Range; + function Length (Source : Bounded_String) return Length_Range with + Global => null; -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- @@ -62,162 +71,302 @@ package Ada.Strings.Bounded is function To_Bounded_String (Source : String; - Drop : Truncation := Error) return Bounded_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; - function To_String (Source : Bounded_String) return String; + function To_String (Source : Bounded_String) return String with + Post => To_String'Result'Length = Length (Source), + Global => null; procedure Set_Bounded_String (Target : out Bounded_String; Source : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => (if Source'Length > Max_Length then Drop /= Error), + Post => Length (Target) = Natural'Min (Max_Length, Source'Length), + Global => null; pragma Ada_05 (Set_Bounded_String); function Append (Left : Bounded_String; Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + 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; function Append (Left : Bounded_String; Right : String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + 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; function Append (Left : String; Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + 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; function Append (Left : Bounded_String; Right : Character; - Drop : Truncation := Error) return Bounded_String; + 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; function Append (Left : Character; Right : Bounded_String; - Drop : Truncation := Error) return 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; procedure Append (Source : in out Bounded_String; New_Item : Bounded_String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + 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; procedure Append (Source : in out Bounded_String; New_Item : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + 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; procedure Append (Source : in out Bounded_String; New_Item : Character; - Drop : Truncation := Error); + 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; function "&" (Left : Bounded_String; - Right : Bounded_String) return 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; function "&" (Left : Bounded_String; - Right : String) return Bounded_String; + Right : String) return Bounded_String + with + Pre => Right'Length <= Max_Length - Length (Left), + Post => Length ("&"'Result) = Length (Left) + Right'Length, + Global => null; function "&" (Left : String; - Right : Bounded_String) return Bounded_String; + Right : Bounded_String) return Bounded_String + with + Pre => Left'Length <= Max_Length - Length (Right), + Post => Length ("&"'Result) = Left'Length + Length (Right), + Global => null; function "&" (Left : Bounded_String; - Right : Character) return Bounded_String; + Right : Character) return Bounded_String + with + Pre => Length (Left) < Max_Length, + Post => Length ("&"'Result) = Length (Left) + 1, + Global => null; function "&" (Left : Character; - Right : Bounded_String) return Bounded_String; + Right : Bounded_String) return Bounded_String + with + Pre => Length (Right) < Max_Length, + Post => Length ("&"'Result) = 1 + Length (Right), + Global => null; function Element (Source : Bounded_String; - Index : Positive) return Character; + Index : Positive) return Character + with + Pre => Index <= Length (Source), + Global => null; procedure Replace_Element (Source : in out Bounded_String; Index : Positive; - By : Character); + By : Character) + with + Pre => Index <= Length (Source), + Post => Length (Source) = Length (Source)'Old, + Global => null; function Slice (Source : Bounded_String; Low : Positive; - High : Natural) return String; + 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; function Bounded_Slice (Source : Bounded_String; Low : Positive; - High : Natural) return Bounded_String; + 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), + Global => null; pragma Ada_05 (Bounded_Slice); procedure Bounded_Slice (Source : Bounded_String; Target : out Bounded_String; Low : Positive; - High : Natural); + High : Natural) + with + Pre => Low - 1 <= Length (Source) and then High <= Length (Source), + Post => Length (Target) = Natural'Max (0, High - Low + 1), + Global => null; pragma Ada_05 (Bounded_Slice); function "=" (Left : Bounded_String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function "=" (Left : Bounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "=" (Left : String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function "<" (Left : Bounded_String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function "<" (Left : Bounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "<" (Left : String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function "<=" (Left : Bounded_String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function "<=" (Left : Bounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "<=" (Left : String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function ">" (Left : Bounded_String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function ">" (Left : Bounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function ">" (Left : String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function ">=" (Left : Bounded_String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; function ">=" (Left : Bounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function ">=" (Left : String; - Right : Bounded_String) return Boolean; + Right : Bounded_String) return Boolean + with + Global => null; ---------------------- -- Search Functions -- @@ -227,26 +376,40 @@ package Ada.Strings.Bounded is (Source : Bounded_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, + Global => null; function Index (Source : Bounded_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, + Global => null; function Index (Source : Bounded_String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Global => null; function Index (Source : Bounded_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 Length (Source) /= 0 + then From <= Length (Source)) + and then Pattern'Length /= 0, + Global => null; pragma Ada_05 (Index); function Index @@ -254,7 +417,13 @@ package Ada.Strings.Bounded is Pattern : String; From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => + (if Length (Source) /= 0 + then From <= Length (Source)) + and then Pattern'Length /= 0, + Global => null; pragma Ada_05 (Index); function Index @@ -262,32 +431,48 @@ package Ada.Strings.Bounded is Set : Maps.Character_Set; From : Positive; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_05 (Index); function Index_Non_Blank (Source : Bounded_String; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Global => null; function Index_Non_Blank (Source : Bounded_String; From : Positive; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_05 (Index_Non_Blank); function Count (Source : Bounded_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 Count (Source : Bounded_String; Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length /= 0, + Global => null; function Count (Source : Bounded_String; - Set : Maps.Character_Set) return Natural; + Set : Maps.Character_Set) return Natural + with + Global => null; procedure Find_Token (Source : Bounded_String; @@ -295,7 +480,10 @@ package Ada.Strings.Bounded is From : Positive; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_2012 (Find_Token); procedure Find_Token @@ -303,7 +491,9 @@ package Ada.Strings.Bounded is Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Global => null; ------------------------------------ -- String Translation Subprograms -- @@ -311,19 +501,31 @@ package Ada.Strings.Bounded is function Translate (Source : Bounded_String; - Mapping : Maps.Character_Mapping) return Bounded_String; + Mapping : Maps.Character_Mapping) return Bounded_String + with + Post => Length (Translate'Result) = Length (Source), + Global => null; procedure Translate (Source : in out Bounded_String; - Mapping : Maps.Character_Mapping); + Mapping : Maps.Character_Mapping) + with + Post => Length (Source) = Length (Source)'Old, + Global => null; function Translate (Source : Bounded_String; - Mapping : Maps.Character_Mapping_Function) return Bounded_String; + Mapping : Maps.Character_Mapping_Function) return Bounded_String + with + Post => Length (Translate'Result) = Length (Source), + Global => null; procedure Translate (Source : in out Bounded_String; - Mapping : Maps.Character_Mapping_Function); + Mapping : Maps.Character_Mapping_Function) + with + Post => Length (Source) = Length (Source)'Old, + Global => null; --------------------------------------- -- String Transformation Subprograms -- @@ -334,48 +536,149 @@ package Ada.Strings.Bounded is Low : Positive; High : Natural; By : String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + 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)), + 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; procedure Replace_Slice (Source : in out Bounded_String; Low : Positive; High : Natural; By : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + 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)), + 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; function Insert (Source : Bounded_String; Before : Positive; New_Item : String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + 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; procedure Insert (Source : in out Bounded_String; Before : Positive; New_Item : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + 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; function Overwrite (Source : Bounded_String; Position : Positive; New_Item : String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + 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; procedure Overwrite (Source : in out Bounded_String; Position : Positive; New_Item : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + 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; function Delete (Source : Bounded_String; From : Positive; - Through : Natural) return Bounded_String; + Through : Natural) return Bounded_String + with + Pre => + (if Through <= From then From - 1 <= Length (Source)), + Contract_Cases => + (Through >= From => + Length (Delete'Result) = Length (Source) - (Through - From + 1), + others => + Length (Delete'Result) = Length (Source)), + + Global => null; procedure Delete (Source : in out Bounded_String; From : Positive; - Through : Natural); + Through : Natural) + with + Pre => + (if Through <= From then From - 1 <= Length (Source)), + Contract_Cases => + (Through >= From => + Length (Source) = Length (Source)'Old - (Through - From + 1), + others => + Length (Source) = Length (Source)'Old), + Global => null; --------------------------------- -- String Selector Subprograms -- @@ -383,45 +686,73 @@ package Ada.Strings.Bounded is function Trim (Source : Bounded_String; - Side : Trim_End) return Bounded_String; + Side : Trim_End) return Bounded_String + with + Post => Length (Trim'Result) <= Length (Source), + Global => null; procedure Trim (Source : in out Bounded_String; - Side : Trim_End); + Side : Trim_End) + with + Post => Length (Source) <= Length (Source)'Old, + Global => null; function Trim (Source : Bounded_String; Left : Maps.Character_Set; - Right : Maps.Character_Set) return Bounded_String; + Right : Maps.Character_Set) return Bounded_String + with + Post => Length (Trim'Result) <= Length (Source), + Global => null; procedure Trim (Source : in out Bounded_String; Left : Maps.Character_Set; - Right : Maps.Character_Set); + Right : Maps.Character_Set) + with + Post => Length (Source) <= Length (Source)'Old, + Global => null; function Head (Source : Bounded_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error) return Bounded_String; + 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; procedure Head (Source : in out Bounded_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => (if Count > Max_Length then Drop /= Error), + Post => Length (Source) = Natural'Min (Max_Length, Count), + Global => null; function Tail (Source : Bounded_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error) return Bounded_String; + 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; procedure Tail (Source : in out Bounded_String; Count : Natural; Pad : Character := Space; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => (if Count > Max_Length then Drop /= Error), + Post => Length (Source) = Natural'Min (Max_Length, Count), + Global => null; ------------------------------------ -- String Constructor Subprograms -- @@ -429,30 +760,66 @@ package Ada.Strings.Bounded is function "*" (Left : Natural; - Right : Character) return Bounded_String; + Right : Character) return Bounded_String + with + Pre => Left <= Max_Length, + Post => Length ("*"'Result) = Left, + Global => null; function "*" (Left : Natural; - Right : String) return Bounded_String; + Right : String) return Bounded_String + with + Pre => (if Left /= 0 then Right'Length <= Max_Length / Left), + Post => Length ("*"'Result) = Left * Right'Length, + Global => null; function "*" (Left : Natural; - Right : Bounded_String) return Bounded_String; + 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; function Replicate (Count : Natural; Item : Character; - Drop : Truncation := Error) return Bounded_String; + 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; function Replicate (Count : Natural; Item : String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + Pre => + (if Item'Length /= 0 + and then Count > Max_Length / Item'Length + then Drop /= Error), + Post => + Length (Replicate'Result) + = Natural'Min (Max_Length, Count * Item'Length), + Global => null; function Replicate (Count : Natural; Item : Bounded_String; - Drop : Truncation := Error) return Bounded_String; + Drop : Truncation := Error) return Bounded_String + with + Pre => + (if Length (Item) /= 0 + and then Count > Max_Length / Length (Item) + then Drop /= Error), + Post => + Length (Replicate'Result) + = Natural'Min (Max_Length, Count * Length (Item)), + Global => null; private -- Most of the implementation is in the separate non generic package diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb index 6bf825b..b8b5f42 100644 --- a/gcc/ada/libgnat/a-strfix.adb +++ b/gcc/ada/libgnat/a-strfix.adb @@ -192,7 +192,15 @@ package body Ada.Strings.Fixed is elsif From not in Source'Range or else Through > Source'Last then - raise Index_Error; + -- In most cases this raises an exception, but the case of deleting + -- a null string at the end of the current one is a special-case, and + -- reflects the equivalence with Replace_String (RM A.4.3 (86/3)). + + if From = Source'Last + 1 and then From = Through then + return Source; + else + raise Index_Error; + end if; else declare diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads index 56db8bc..7d6e121 100644 --- a/gcc/ada/libgnat/a-strfix.ads +++ b/gcc/ada/libgnat/a-strfix.ads @@ -13,9 +13,34 @@ -- -- ------------------------------------------------------------------------------ +-- 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; -package Ada.Strings.Fixed is +-- The language-defined package Strings.Fixed provides string-handling +-- subprograms for fixed-length strings; that is, for values of type +-- Standard.String. Several of these subprograms are procedures that modify +-- the contents of a String that is passed as an out or an in out parameter; +-- each has additional parameters to control the effect when the logical +-- length of the result differs from the parameter's length. +-- +-- For each function that returns a String, the lower bound of the returned +-- value is 1. +-- +-- The basic model embodied in the package is that a fixed-length string +-- comprises significant characters and possibly padding (with space +-- characters) on either or both ends. When a shorter string is copied to a +-- longer string, padding is inserted, and when a longer string is copied to a +-- shorter one, padding is stripped. The Move procedure in Strings.Fixed, +-- which takes a String as an out parameter, allows the programmer to control +-- these effects. Similar control is provided by the string transformation +-- procedures. + +package Ada.Strings.Fixed with SPARK_Mode is pragma Preelaborate; -------------------------------------------------------------- @@ -27,7 +52,50 @@ package Ada.Strings.Fixed is Target : out String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space); + Pad : Character := Space) + with + + -- Incomplete contract + + Global => null; + -- The Move procedure copies characters from Source to Target. If Source + -- has the same length as Target, then the effect is to assign Source to + -- Target. If Source is shorter than Target then: + -- + -- * If Justify=Left, then Source is copied into the first Source'Length + -- characters of Target. + -- + -- * If Justify=Right, then Source is copied into the last Source'Length + -- characters of Target. + -- + -- * If Justify=Center, then Source is copied into the middle Source'Length + -- characters of Target. In this case, if the difference in length + -- between Target and Source is odd, then the extra Pad character is on + -- the right. + -- + -- * Pad is copied to each Target character not otherwise assigned. + -- + -- If Source is longer than Target, then the effect is based on Drop. + -- + -- * If Drop=Left, then the rightmost Target'Length characters of Source + -- are copied into Target. + -- + -- * If Drop=Right, then the leftmost Target'Length characters of Source + -- are copied into Target. + -- + -- * If Drop=Error, then the effect depends on the value of the Justify + -- parameter and also on whether any characters in Source other than Pad + -- would fail to be copied: + -- + -- * If Justify=Left, and if each of the rightmost + -- Source'Length-Target'Length characters in Source is Pad, then the + -- leftmost Target'Length characters of Source are copied to Target. + -- + -- * If Justify=Right, and if each of the leftmost + -- Source'Length-Target'Length characters in Source is Pad, then the + -- rightmost Target'Length characters of Source are copied to Target. + -- + -- * Otherwise, Length_Error is propagated. ------------------------ -- Search Subprograms -- @@ -36,68 +104,139 @@ package Ada.Strings.Fixed is function Index (Source : String; Pattern : String; + From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => + Pattern'Length /= 0 + and then (if Source'Length /= 0 then From in Source'Range), + Global => null; + pragma Ada_05 (Index); function Index (Source : String; Pattern : String; + From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => + Pattern'Length /= 0 + and then (if Source'Length /= 0 then From in Source'Range), + Global => null; + pragma Ada_05 (Index); - function Index - (Source : String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; + -- Each Index function searches, starting from From, for a slice of + -- Source, with length Pattern'Length, that matches Pattern with respect to + -- Mapping; the parameter Going indicates the direction of the lookup. If + -- Source is the null string, Index returns 0; otherwise, if From is not in + -- Source'Range, then Index_Error is propagated. If Going = Forward, then + -- Index returns the smallest index I which is greater than or equal to + -- From such that the slice of Source starting at I matches Pattern. If + -- Going = Backward, then Index returns the largest index I such that the + -- slice of Source starting at I matches Pattern and has an upper bound + -- less than or equal to From. If there is no such slice, then 0 is + -- returned. If Pattern is the null string, then Pattern_Error is + -- propagated. function Index (Source : String; Pattern : String; - From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - pragma Ada_05 (Index); + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + with + Pre => Pattern'Length > 0, + Global => null; function Index (Source : String; Pattern : String; - From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length /= 0, + Global => null; + + -- If Going = Forward, returns: + -- + -- Index (Source, Pattern, Source'First, Forward, Mapping) + -- + -- otherwise, returns: + -- + -- Index (Source, Pattern, Source'Last, Backward, Mapping). + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + with + Global => null; function Index (Source : String; Set : Maps.Character_Set; From : Positive; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Source'Length /= 0 then From in Source'Range), + Global => null; pragma Ada_05 (Index); + -- Index searches for the first or last occurrence of any of a set of + -- characters (when Test=Inside), or any of the complement of a set of + -- characters (when Test=Outside). If Source is the null string, Index + -- returns 0; otherwise, if From is not in Source'Range, then Index_Error + -- is propagated. Otherwise, it returns the smallest index I >= From (if + -- Going=Forward) or the largest index I <= From (if Going=Backward) such + -- that Source(I) satisfies the Test condition with respect to Set; it + -- returns 0 if there is no such Character in Source. function Index_Non_Blank (Source : String; - Going : Direction := Forward) return Natural; + From : Positive; + Going : Direction := Forward) return Natural + with + Pre => (if Source'Length /= 0 then From in Source'Range), + Global => null; + pragma Ada_05 (Index_Non_Blank); + -- Returns Index (Source, Maps.To_Set(Space), From, Outside, Going) function Index_Non_Blank (Source : String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); + Going : Direction := Forward) return Natural + with + Global => null; + -- Returns Index (Source, Maps.To_Set(Space), Outside, Going) function Count (Source : 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 Count (Source : String; Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length /= 0, + Global => null; + + -- Returns the maximum number of nonoverlapping slices of Source that match + -- Pattern with respect to Mapping. If Pattern is the null string then + -- Pattern_Error is propagated. function Count (Source : String; - Set : Maps.Character_Set) return Natural; + Set : Maps.Character_Set) return Natural + with + Global => null; + -- Returns the number of occurrences in Source of characters that are in + -- Set. procedure Find_Token (Source : String; @@ -105,15 +244,28 @@ package Ada.Strings.Fixed is From : Positive; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Pre => (if Source'Length /= 0 then From in Source'Range), + Global => null; pragma Ada_2012 (Find_Token); + -- If Source is not the null string and From is not in Source'Range, then + -- Index_Error is raised. Otherwise, First is set to the index of the first + -- character in Source(From .. Source'Last) that satisfies the Test + -- condition. Last is set to the largest index such that all characters in + -- Source(First .. Last) satisfy the Test condition. If no characters in + -- Source(From .. Source'Last) satisfy the Test condition, First is set to + -- From, and Last is set to 0. procedure Find_Token (Source : String; Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Global => null; + -- Equivalent to Find_Token (Source, Set, Source'First, Test, First, Last) ------------------------------------ -- String Translation Subprograms -- @@ -121,30 +273,40 @@ package Ada.Strings.Fixed is function Translate (Source : String; - Mapping : Maps.Character_Mapping) return String; - - procedure Translate - (Source : in out String; - Mapping : Maps.Character_Mapping); + Mapping : Maps.Character_Mapping_Function) return String + with + Post => Translate'Result'Length = Source'Length, + Global => null; function Translate (Source : String; - Mapping : Maps.Character_Mapping_Function) return String; + Mapping : Maps.Character_Mapping) return String + with + Post => Translate'Result'Length = Source'Length, + Global => null; + + -- Returns the string S whose length is Source'Length and such that S (I) + -- is the character to which Mapping maps the corresponding element of + -- Source, for I in 1 .. Source'Length. procedure Translate (Source : in out String; - Mapping : Maps.Character_Mapping_Function); + Mapping : Maps.Character_Mapping_Function) + with + Global => null; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping) + with + Global => null; + + -- Equivalent to Source := Translate(Source, Mapping) --------------------------------------- -- String Transformation Subprograms -- --------------------------------------- - function Replace_Slice - (Source : String; - Low : Positive; - High : Natural; - By : String) return String; - procedure Replace_Slice (Source : in out String; Low : Positive; @@ -152,41 +314,152 @@ package Ada.Strings.Fixed is By : String; Drop : Truncation := Error; Justify : Alignment := Left; - Pad : Character := Space); + Pad : Character := Space) + with + Pre => + + -- Incomplete contract + + Low - 1 <= Source'Last + and then High >= Source'First - 1, + Global => null; + -- If Low > Source'Last+1, or High < Source'First - 1, then Index_Error is + -- propagated. Otherwise: + -- + -- * If High >= Low, then the returned string comprises + -- Source (Source'First .. Low - 1) + -- & By & Source(High + 1 .. Source'Last), but with lower bound 1. + -- + -- * If High < Low, then the returned string is + -- Insert (Source, Before => Low, New_Item => By). + + function Replace_Slice + (Source : String; + Low : Positive; + High : Natural; + By : String) return String + with + 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), + Contract_Cases => + (High >= Low => + Replace_Slice'Result'Length + = Natural'Max (0, Low - Source'First) + + By'Length + + Natural'Max (Source'Last - High, 0), + others => + Replace_Slice'Result'Length = Source'Length + By'Length), + Global => null; + -- Equivalent to: + -- + -- Move (Replace_Slice (Source, Low, High, By), + -- Source, Drop, Justify, Pad). function Insert (Source : String; Before : Positive; - New_Item : String) return String; + New_Item : String) return String + with + Pre => + Before - 1 in Source'First - 1 .. Source'Last + and then Source'Length <= Natural'Last - New_Item'Length, + Post => Insert'Result'Length = Source'Length + New_Item'Length, + Global => null; + -- Propagates Index_Error if Before is not in + -- Source'First .. Source'Last+1; otherwise, returns + -- Source (Source'First .. Before - 1) + -- & New_Item & Source(Before..Source'Last), but with lower bound 1. procedure Insert (Source : in out String; Before : Positive; New_Item : String; - Drop : Truncation := Error); + Drop : Truncation := Error) + with + Pre => Before - 1 in Source'First - 1 .. Source'Last, + + -- Incomplete contract + + Global => null; + -- Equivalent to Move (Insert (Source, Before, New_Item), Source, Drop) function Overwrite (Source : String; Position : Positive; - New_Item : String) return String; + New_Item : String) return String + with + 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), + Post => + Overwrite'Result'Length + = Integer'Max (Source'Length, + Position - Source'First + New_Item'Length), + Global => null; + -- Propagates Index_Error if Position is not in + -- Source'First .. Source'Last + 1; otherwise, returns the string obtained + -- from Source by consecutively replacing characters starting at Position + -- with corresponding characters from New_Item. If the end of Source is + -- reached before the characters in New_Item are exhausted, the remaining + -- characters from New_Item are appended to the string. procedure Overwrite (Source : in out String; Position : Positive; New_Item : String; - Drop : Truncation := Right); + Drop : Truncation := Right) + with + Pre => Position - 1 in Source'First - 1 .. Source'Last, + + -- Incomplete contract + + Global => null; + -- Equivalent to Move(Overwrite(Source, Position, New_Item), Source, Drop) function Delete (Source : String; From : Positive; - Through : Natural) return String; + Through : Natural) return String + with + Pre => (if From <= Through + then (From in Source'Range + and then Through <= Source'Last)), + Post => + Delete'Result'Length + = Source'Length - (if From <= Through + then Through - From + 1 + else 0), + Global => null; + -- If From <= Through, the returned string is + -- Replace_Slice(Source, From, Through, ""); otherwise, it is Source with + -- lower bound 1. procedure Delete (Source : in out String; From : Positive; Through : Natural; Justify : Alignment := Left; - Pad : Character := Space); + Pad : Character := Space) + with + Pre => (if From <= Through + then (From in Source'Range + and then Through <= Source'Last)), + + -- Incomplete contract + + Global => null; + -- Equivalent to: + -- + -- Move (Delete (Source, From, Through), + -- Source, Justify => Justify, Pad => Pad). --------------------------------- -- String Selector Subprograms -- @@ -194,47 +467,106 @@ package Ada.Strings.Fixed is function Trim (Source : String; - Side : Trim_End) return String; + Side : Trim_End) return String + with + Post => Trim'Result'Length <= Source'Length, + Global => null; + -- Returns the string obtained by removing from Source all leading Space + -- characters (if Side = Left), all trailing Space characters (if + -- Side = Right), or all leading and trailing Space characters (if + -- Side = Both). procedure Trim (Source : in out String; Side : Trim_End; Justify : Alignment := Left; - Pad : Character := Space); + Pad : Character := Space) + with + + -- Incomplete contract + + Global => null; + -- Equivalent to: + -- + -- Move (Trim (Source, Side), Source, Justify=>Justify, Pad=>Pad). function Trim (Source : String; Left : Maps.Character_Set; - Right : Maps.Character_Set) return String; + Right : Maps.Character_Set) return String + with + Post => Trim'Result'Length <= Source'Length, + Global => null; + -- Returns the string obtained by removing from Source all leading + -- characters in Left and all trailing characters in Right. procedure Trim (Source : in out String; Left : Maps.Character_Set; Right : Maps.Character_Set; Justify : Alignment := Strings.Left; - Pad : Character := Space); + Pad : Character := Space) + with + + -- Incomplete contract + + Global => null; + -- Equivalent to: + -- + -- Move (Trim (Source, Left, Right), + -- Source, Justify => Justify, Pad=>Pad). function Head (Source : String; Count : Natural; - Pad : Character := Space) return String; + Pad : Character := Space) return String + with + Post => Head'Result'Length = Count, + Global => null; + -- Returns a string of length Count. If Count <= Source'Length, the string + -- comprises the first Count characters of Source. Otherwise, its contents + -- are Source concatenated with Count - Source'Length Pad characters. procedure Head (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space); + Pad : Character := Space) + with + + -- Incomplete contract + + Global => null; + -- Equivalent to: + -- + -- Move (Head (Source, Count, Pad), + -- Source, Drop => Error, Justify => Justify, Pad => Pad). function Tail (Source : String; Count : Natural; - Pad : Character := Space) return String; + Pad : Character := Space) return String + with + Post => Tail'Result'Length = Count, + Global => null; + -- Returns a string of length Count. If Count <= Source'Length, the string + -- comprises the last Count characters of Source. Otherwise, its contents + -- are Count-Source'Length Pad characters concatenated with Source. procedure Tail (Source : in out String; Count : Natural; Justify : Alignment := Left; - Pad : Character := Space); + Pad : Character := Space) + with + + -- Incomplete contract + + Global => null; + -- Equivalent to: + -- + -- Move (Tail (Source, Count, Pad), + -- Source, Drop => Error, Justify => Justify, Pad => Pad). ---------------------------------- -- String Constructor Functions -- @@ -242,10 +574,23 @@ package Ada.Strings.Fixed is function "*" (Left : Natural; - Right : Character) return String; + Right : Character) return String + with + Post => "*"'Result'Length = Left, + Global => null; function "*" (Left : Natural; - Right : String) return String; + Right : String) return String + with + Pre => (if Right'Length /= 0 then Left <= Natural'Last / Right'Length), + Post => "*"'Result'Length = Left * Right'Length, + Global => null; + + -- These functions replicate a character or string a specified number of + -- times. The first function returns a string whose length is Left and each + -- of whose elements is Right. The second function returns a string whose + -- length is Left * Right'Length and whose value is the null string if + -- Left = 0 and otherwise is (Left - 1)*Right & Right with lower bound 1. end Ada.Strings.Fixed; diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads index 601e69e..e875b5b 100644 --- a/gcc/ada/libgnat/a-strunb.ads +++ b/gcc/ada/libgnat/a-strunb.ads @@ -33,158 +33,318 @@ -- -- ------------------------------------------------------------------------------ +-- 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; with Ada.Finalization; -package Ada.Strings.Unbounded is +-- The language-defined package Strings.Unbounded provides a private type +-- Unbounded_String and a set of operations. An object of type +-- Unbounded_String represents a String whose low bound is 1 and whose length +-- can vary conceptually between 0 and Natural'Last. The subprograms for +-- fixed-length string handling are either overloaded directly for +-- Unbounded_String, or are modified as needed to reflect the flexibility in +-- length. Since the Unbounded_String type is private, relevant constructor +-- and selector operations are provided. + +package Ada.Strings.Unbounded with + Initial_Condition => Length (Null_Unbounded_String) = 0 +is pragma Preelaborate; type Unbounded_String is private; pragma Preelaborable_Initialization (Unbounded_String); Null_Unbounded_String : constant Unbounded_String; + -- Represents the null String. If an object of type Unbounded_String is not + -- otherwise initialized, it will be initialized to the same value as + -- Null_Unbounded_String. - function Length (Source : Unbounded_String) return Natural; + function Length (Source : Unbounded_String) return Natural with + Global => null; + -- Returns the length of the String represented by Source type String_Access is access all String; + -- Provides a (nonprivate) access type for explicit processing of + -- unbounded-length strings. procedure Free (X : in out String_Access); + -- Performs an unchecked deallocation of an object of type String_Access -------------------------------------------------------- -- Conversion, Concatenation, and Selection Functions -- -------------------------------------------------------- function To_Unbounded_String - (Source : String) return Unbounded_String; + (Source : String) return Unbounded_String + with + Post => Length (To_Unbounded_String'Result) = Source'Length, + Global => null; + -- Returns an Unbounded_String that represents Source function To_Unbounded_String - (Length : Natural) return Unbounded_String; - - function To_String (Source : Unbounded_String) return String; + (Length : Natural) return Unbounded_String + with + Post => + Ada.Strings.Unbounded.Length (To_Unbounded_String'Result) + = Length, + Global => null; + -- Returns an Unbounded_String that represents an uninitialized String + -- whose length is Length. + + function To_String (Source : Unbounded_String) return String with + Post => To_String'Result'Length = Length (Source), + Global => null; + -- Returns the String with lower bound 1 represented by Source + + -- To_String and To_Unbounded_String are related as follows: + -- + -- * If S is a String, then To_String (To_Unbounded_String (S)) = S. + -- + -- * If U is an Unbounded_String, then + -- To_Unbounded_String (To_String (U)) = U. procedure Set_Unbounded_String (Target : out Unbounded_String; - Source : String); + Source : String) + with + Global => null; pragma Ada_05 (Set_Unbounded_String); + -- Sets Target to an Unbounded_String that represents Source procedure Append (Source : in out Unbounded_String; - New_Item : Unbounded_String); + New_Item : Unbounded_String) + with + Pre => Length (New_Item) <= Natural'Last - Length (Source), + Post => Length (Source) = Length (Source)'Old + Length (New_Item), + Global => null; procedure Append (Source : in out Unbounded_String; - New_Item : String); + New_Item : String) + with + Pre => New_Item'Length <= Natural'Last - Length (Source), + Post => Length (Source) = Length (Source)'Old + New_Item'Length, + Global => null; procedure Append (Source : in out Unbounded_String; - New_Item : Character); + New_Item : Character) + with + Pre => Length (Source) < Natural'Last, + Post => Length (Source) = Length (Source)'Old + 1, + Global => null; + + -- For each of the Append procedures, the resulting string represented by + -- the Source parameter is given by the concatenation of the original value + -- of Source and the value of New_Item. function "&" (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => Length (Right) <= Natural'Last - Length (Left), + Post => Length ("&"'Result) = Length (Left) + Length (Right), + Global => null; function "&" (Left : Unbounded_String; - Right : String) return Unbounded_String; + Right : String) return Unbounded_String + with + Pre => Right'Length <= Natural'Last - Length (Left), + Post => Length ("&"'Result) = Length (Left) + Right'Length, + Global => null; function "&" (Left : String; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => Left'Length <= Natural'Last - Length (Right), + Post => Length ("&"'Result) = Left'Length + Length (Right), + Global => null; function "&" (Left : Unbounded_String; - Right : Character) return Unbounded_String; + Right : Character) return Unbounded_String + with + Pre => Length (Left) < Natural'Last, + Post => Length ("&"'Result) = Length (Left) + 1, + Global => null; function "&" (Left : Character; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => Length (Right) < Natural'Last, + Post => Length ("&"'Result) = Length (Right) + 1, + Global => null; + + -- Each of the "&" functions returns an Unbounded_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_Unbounded_String to the concatenation + -- result string. function Element (Source : Unbounded_String; - Index : Positive) return Character; + Index : Positive) return Character + 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 Unbounded_String; Index : Positive; - By : Character); + By : Character) + with + Pre => Index <= Length (Source), + Post => Length (Source) = Length (Source)'Old, + 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 : Unbounded_String; Low : Positive; - High : Natural) return String; + 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 Unbounded_Slice (Source : Unbounded_String; Low : Positive; - High : Natural) return Unbounded_String; + High : Natural) return Unbounded_String + with + Pre => Low - 1 <= Length (Source) and then High <= Length (Source), + Post => + Length (Unbounded_Slice'Result) = Natural'Max (0, High - Low + 1), + Global => null; pragma Ada_05 (Unbounded_Slice); + -- Returns the slice at positions Low through High in the string + -- represented by Source as an Unbounded_String. This propagates + -- Index_Error if Low > Length(Source) + 1 or High > Length (Source). procedure Unbounded_Slice (Source : Unbounded_String; Target : out Unbounded_String; Low : Positive; - High : Natural); + High : Natural) + with + Pre => Low - 1 <= Length (Source) and then High <= Length (Source), + Post => Length (Target) = Natural'Max (0, High - Low + 1), + Global => null; pragma Ada_05 (Unbounded_Slice); + -- Sets Target to the Unbounded_String representing the slice at positions + -- Low through High in the string represented by Source. This propagates + -- Index_Error if Low > Length(Source) + 1 or High > Length (Source). function "=" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "=" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "=" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "<" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<=" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<=" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "<=" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function ">" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">=" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">=" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function ">=" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; + + -- Each of the functions "=", "<", ">", "<=", and ">=" returns the same + -- result as the corresponding String operation applied to the String + -- values given or represented by Left and Right. ------------------------ -- Search Subprograms -- @@ -194,26 +354,38 @@ package Ada.Strings.Unbounded is (Source : Unbounded_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, + Global => null; function Index (Source : Unbounded_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, + Global => null; function Index (Source : Unbounded_String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Global => null; function Index (Source : Unbounded_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 Length (Source) /= 0 then From <= Length (Source)) + and then Pattern'Length /= 0, + Global => null; pragma Ada_05 (Index); function Index @@ -221,7 +393,11 @@ package Ada.Strings.Unbounded is Pattern : String; From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)) + and then Pattern'Length /= 0, + Global => null; pragma Ada_05 (Index); function Index @@ -229,32 +405,48 @@ package Ada.Strings.Unbounded is Set : Maps.Character_Set; From : Positive; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_05 (Index); function Index_Non_Blank (Source : Unbounded_String; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Global => null; function Index_Non_Blank (Source : Unbounded_String; From : Positive; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_05 (Index_Non_Blank); function Count (Source : Unbounded_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 Count (Source : Unbounded_String; Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length /= 0, + Global => null; function Count (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural; + Set : Maps.Character_Set) return Natural + with + Global => null; procedure Find_Token (Source : Unbounded_String; @@ -262,7 +454,10 @@ package Ada.Strings.Unbounded is From : Positive; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_2012 (Find_Token); procedure Find_Token @@ -270,7 +465,14 @@ package Ada.Strings.Unbounded is Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Global => null; + + -- 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 Unbounded_String + -- parameter. ------------------------------------ -- String Translation Subprograms -- @@ -278,19 +480,36 @@ package Ada.Strings.Unbounded is function Translate (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String + with + Post => Length (Translate'Result) = Length (Source), + Global => null; procedure Translate (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping); + Mapping : Maps.Character_Mapping) + with + Post => Length (Source) = Length (Source)'Old, + Global => null; function Translate (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String + with + Post => Length (Translate'Result) = Length (Source), + Global => null; procedure Translate (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function); + Mapping : Maps.Character_Mapping_Function) + with + Post => Length (Source) = Length (Source)'Old, + Global => null; + + -- The Translate function has an analogous effect to the corresponding + -- subprogram in Strings.Fixed. The translation is applied to the string + -- represented by the Unbounded_String parameter, and the result is + -- converted (via To_Unbounded_String) to an Unbounded_String. --------------------------------------- -- String Transformation Subprograms -- @@ -300,93 +519,217 @@ package Ada.Strings.Unbounded is (Source : Unbounded_String; Low : Positive; High : Natural; - By : String) return Unbounded_String; + By : String) return Unbounded_String + with + Pre => + Low - 1 <= Length (Source) + and then (if High >= Low + then Low - 1 + <= Natural'Last - By'Length + - Natural'Max (Length (Source) - High, 0) + else Length (Source) <= Natural'Last - By'Length), + Contract_Cases => + (High >= Low => + Length (Replace_Slice'Result) + = Low - 1 + By'Length + Natural'Max (Length (Source)'Old - High, 0), + others => + Length (Replace_Slice'Result) = Length (Source)'Old + By'Length), + Global => null; procedure Replace_Slice (Source : in out Unbounded_String; Low : Positive; High : Natural; - By : String); + By : String) + with + Pre => + Low - 1 <= Length (Source) + and then (if High >= Low + then Low - 1 + <= Natural'Last - By'Length + - Natural'Max (Length (Source) - High, 0) + else Length (Source) <= Natural'Last - By'Length), + Contract_Cases => + (High >= Low => + Length (Source) + = Low - 1 + By'Length + Natural'Max (Length (Source)'Old - High, 0), + others => + Length (Source) = Length (Source)'Old + By'Length), + Global => null; function Insert (Source : Unbounded_String; Before : Positive; - New_Item : String) return Unbounded_String; + New_Item : String) return Unbounded_String + with + Pre => Before - 1 <= Length (Source) + and then New_Item'Length <= Natural'Last - Length (Source), + Post => Length (Insert'Result) = Length (Source) + New_Item'Length, + Global => null; procedure Insert (Source : in out Unbounded_String; Before : Positive; - New_Item : String); + New_Item : String) + with + Pre => Before - 1 <= Length (Source) + and then New_Item'Length <= Natural'Last - Length (Source), + Post => Length (Source) = Length (Source)'Old + New_Item'Length, + Global => null; function Overwrite (Source : Unbounded_String; Position : Positive; - New_Item : String) return Unbounded_String; + New_Item : String) return Unbounded_String + with + Pre => Position - 1 <= Length (Source) + and then (if New_Item'Length /= 0 + then + New_Item'Length <= Natural'Last - (Position - 1)), + Post => + Length (Overwrite'Result) + = Natural'Max (Length (Source), Position - 1 + New_Item'Length), + Global => null; procedure Overwrite (Source : in out Unbounded_String; Position : Positive; - New_Item : String); + New_Item : String) + with + Pre => Position - 1 <= Length (Source) + and then (if New_Item'Length /= 0 + then + New_Item'Length <= Natural'Last - (Position - 1)), + Post => + Length (Source) + = Natural'Max (Length (Source)'Old, Position - 1 + New_Item'Length), + + Global => null; function Delete (Source : Unbounded_String; From : Positive; - Through : Natural) return Unbounded_String; + Through : Natural) return Unbounded_String + with + Pre => (if Through <= From then From - 1 <= Length (Source)), + Contract_Cases => + (Through >= From => + Length (Delete'Result) = Length (Source) - (Through - From + 1), + others => + Length (Delete'Result) = Length (Source)), + Global => null; procedure Delete (Source : in out Unbounded_String; From : Positive; - Through : Natural); + Through : Natural) + with + Pre => (if Through <= From then From - 1 <= Length (Source)), + Contract_Cases => + (Through >= From => + Length (Source) = Length (Source)'Old - (Through - From + 1), + others => + Length (Source) = Length (Source)'Old), + Global => null; function Trim (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String; + Side : Trim_End) return Unbounded_String + with + Post => Length (Trim'Result) <= Length (Source), + Global => null; procedure Trim (Source : in out Unbounded_String; - Side : Trim_End); + Side : Trim_End) + with + Post => Length (Source) <= Length (Source)'Old, + Global => null; function Trim (Source : Unbounded_String; Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String; + Right : Maps.Character_Set) return Unbounded_String + with + Post => Length (Trim'Result) <= Length (Source), + Global => null; procedure Trim (Source : in out Unbounded_String; Left : Maps.Character_Set; - Right : Maps.Character_Set); + Right : Maps.Character_Set) + with + Post => Length (Source) <= Length (Source)'Old, + Global => null; function Head (Source : Unbounded_String; Count : Natural; - Pad : Character := Space) return Unbounded_String; + Pad : Character := Space) return Unbounded_String + with + Post => Length (Head'Result) = Count, + Global => null; procedure Head (Source : in out Unbounded_String; Count : Natural; - Pad : Character := Space); + Pad : Character := Space) + with + Post => Length (Source) = Count, + Global => null; function Tail (Source : Unbounded_String; Count : Natural; - Pad : Character := Space) return Unbounded_String; + Pad : Character := Space) return Unbounded_String + with + Post => Length (Tail'Result) = Count, + Global => null; procedure Tail (Source : in out Unbounded_String; Count : Natural; - Pad : Character := Space); + Pad : Character := Space) + with + Post => Length (Source) = Count, + Global => null; function "*" (Left : Natural; - Right : Character) return Unbounded_String; + Right : Character) return Unbounded_String + with + Pre => Left <= Natural'Last, + Post => Length ("*"'Result) = Left, + Global => null; function "*" (Left : Natural; - Right : String) return Unbounded_String; + Right : String) return Unbounded_String + with + Pre => (if Left /= 0 then Right'Length <= Natural'Last / Left), + Post => Length ("*"'Result) = Left * Right'Length, + Global => null; function "*" (Left : Natural; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => (if Left /= 0 then Length (Right) <= Natural'Last / Left), + Post => Length ("*"'Result) = Left * Length (Right), + Global => null; + + -- Each of the transformation functions (Replace_Slice, Insert, Overwrite, + -- Delete), selector functions (Trim, Head, Tail), and constructor + -- functions ("*") is likewise analogous to its corresponding subprogram in + -- Strings.Fixed. For each of the subprograms, the corresponding + -- fixed-length string subprogram is applied to the string represented by + -- the Unbounded_String parameter, and To_Unbounded_String is applied the + -- result string. + -- + -- For each of the procedures Translate, Replace_Slice, Insert, Overwrite, + -- Delete, Trim, Head, and Tail, the resulting string represented by the + -- Source parameter is given by the corresponding function for fixed-length + -- strings applied to the string represented by Source's original value. private pragma Inline (Length); diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads index 385a9e6..17acd56 100644 --- a/gcc/ada/libgnat/a-strunb__shared.ads +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -33,6 +33,12 @@ -- -- ------------------------------------------------------------------------------ +-- 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); + -- This package provides an implementation of Ada.Strings.Unbounded that uses -- reference counts to implement copy on modification (rather than copy on -- assignment). This is significantly more efficient on many targets. @@ -73,7 +79,9 @@ with Ada.Strings.Maps; private with Ada.Finalization; private with System.Atomic_Counters; -package Ada.Strings.Unbounded is +package Ada.Strings.Unbounded with + Initial_Condition => Length (Null_Unbounded_String) = 0 +is pragma Preelaborate; type Unbounded_String is private; @@ -81,7 +89,8 @@ package Ada.Strings.Unbounded is Null_Unbounded_String : constant Unbounded_String; - function Length (Source : Unbounded_String) return Natural; + function Length (Source : Unbounded_String) return Natural with + Global => null; type String_Access is access all String; @@ -92,136 +101,229 @@ package Ada.Strings.Unbounded is -------------------------------------------------------- function To_Unbounded_String - (Source : String) return Unbounded_String; + (Source : String) return Unbounded_String + with + Post => Length (To_Unbounded_String'Result) = Source'Length, + Global => null; function To_Unbounded_String - (Length : Natural) return Unbounded_String; + (Length : Natural) return Unbounded_String + with + Post => + Ada.Strings.Unbounded.Length (To_Unbounded_String'Result) = Length, + Global => null; - function To_String (Source : Unbounded_String) return String; + function To_String (Source : Unbounded_String) return String with + Post => To_String'Result'Length = Length (Source), + Global => null; procedure Set_Unbounded_String (Target : out Unbounded_String; - Source : String); + Source : String) + with + Global => null; pragma Ada_05 (Set_Unbounded_String); procedure Append (Source : in out Unbounded_String; - New_Item : Unbounded_String); + New_Item : Unbounded_String) + with + Pre => Length (New_Item) <= Natural'Last - Length (Source), + Post => Length (Source) = Length (Source)'Old + Length (New_Item), + Global => null; procedure Append (Source : in out Unbounded_String; - New_Item : String); + New_Item : String) + with + Pre => New_Item'Length <= Natural'Last - Length (Source), + Post => Length (Source) = Length (Source)'Old + New_Item'Length, + Global => null; procedure Append (Source : in out Unbounded_String; - New_Item : Character); + New_Item : Character) + with + Pre => Length (Source) < Natural'Last, + Post => Length (Source) = Length (Source)'Old + 1, + Global => null; function "&" (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => Length (Right) <= Natural'Last - Length (Left), + Post => Length ("&"'Result) = Length (Left) + Length (Right), + Global => null; function "&" (Left : Unbounded_String; - Right : String) return Unbounded_String; + Right : String) return Unbounded_String + with + Pre => Right'Length <= Natural'Last - Length (Left), + Post => Length ("&"'Result) = Length (Left) + Right'Length, + Global => null; function "&" (Left : String; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => Left'Length <= Natural'Last - Length (Right), + Post => Length ("&"'Result) = Left'Length + Length (Right), + Global => null; function "&" (Left : Unbounded_String; - Right : Character) return Unbounded_String; + Right : Character) return Unbounded_String + with + Pre => Length (Left) < Natural'Last, + Post => Length ("&"'Result) = Length (Left) + 1, + Global => null; function "&" (Left : Character; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => Length (Right) < Natural'Last, + Post => Length ("&"'Result) = Length (Right) + 1, + Global => null; function Element (Source : Unbounded_String; - Index : Positive) return Character; + Index : Positive) return Character + with + Pre => Index <= Length (Source), + Global => null; procedure Replace_Element (Source : in out Unbounded_String; Index : Positive; - By : Character); + By : Character) + with + Pre => Index <= Length (Source), + Post => Length (Source) = Length (Source)'Old, + Global => null; function Slice (Source : Unbounded_String; Low : Positive; - High : Natural) return String; + 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; function Unbounded_Slice (Source : Unbounded_String; Low : Positive; - High : Natural) return Unbounded_String; + High : Natural) return Unbounded_String + with + Pre => Low - 1 <= Length (Source) and then High <= Length (Source), + Post => + Length (Unbounded_Slice'Result) = Natural'Max (0, High - Low + 1), + Global => null; pragma Ada_05 (Unbounded_Slice); procedure Unbounded_Slice (Source : Unbounded_String; Target : out Unbounded_String; Low : Positive; - High : Natural); + High : Natural) + with + Pre => Low - 1 <= Length (Source) and then High <= Length (Source), + Post => Length (Target) = Natural'Max (0, High - Low + 1), + Global => null; pragma Ada_05 (Unbounded_Slice); function "=" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "=" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "=" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "<" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<=" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function "<=" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function "<=" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function ">" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">=" (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; function ">=" (Left : Unbounded_String; - Right : String) return Boolean; + Right : String) return Boolean + with + Global => null; function ">=" (Left : String; - Right : Unbounded_String) return Boolean; + Right : Unbounded_String) return Boolean + with + Global => null; ------------------------ -- Search Subprograms -- @@ -231,26 +333,39 @@ package Ada.Strings.Unbounded is (Source : Unbounded_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, + Global => null; function Index (Source : Unbounded_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, + Global => null; function Index (Source : Unbounded_String; Set : Maps.Character_Set; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Global => null; function Index (Source : Unbounded_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 Length (Source) /= 0 + then From <= Length (Source)) + and then Pattern'Length /= 0, + Global => null; pragma Ada_05 (Index); function Index @@ -258,7 +373,13 @@ package Ada.Strings.Unbounded is Pattern : String; From : Positive; Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => (if Length (Source) /= 0 + then From <= Length (Source)) + and then Pattern'Length /= 0, + Global => null; + pragma Ada_05 (Index); function Index @@ -266,32 +387,48 @@ package Ada.Strings.Unbounded is Set : Maps.Character_Set; From : Positive; Test : Membership := Inside; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_05 (Index); function Index_Non_Blank (Source : Unbounded_String; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Global => null; function Index_Non_Blank (Source : Unbounded_String; From : Positive; - Going : Direction := Forward) return Natural; + Going : Direction := Forward) return Natural + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_05 (Index_Non_Blank); function Count (Source : Unbounded_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 Count (Source : Unbounded_String; Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; + Mapping : Maps.Character_Mapping_Function) return Natural + with + Pre => Pattern'Length /= 0, + Global => null; function Count (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural; + Set : Maps.Character_Set) return Natural + with + Global => null; procedure Find_Token (Source : Unbounded_String; @@ -299,7 +436,10 @@ package Ada.Strings.Unbounded is From : Positive; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Pre => (if Length (Source) /= 0 then From <= Length (Source)), + Global => null; pragma Ada_2012 (Find_Token); procedure Find_Token @@ -307,7 +447,9 @@ package Ada.Strings.Unbounded is Set : Maps.Character_Set; Test : Membership; First : out Positive; - Last : out Natural); + Last : out Natural) + with + Global => null; ------------------------------------ -- String Translation Subprograms -- @@ -315,19 +457,31 @@ package Ada.Strings.Unbounded is function Translate (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String + with + Post => Length (Translate'Result) = Length (Source), + Global => null; procedure Translate (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping); + Mapping : Maps.Character_Mapping) + with + Post => Length (Source) = Length (Source)'Old, + Global => null; function Translate (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String + with + Post => Length (Translate'Result) = Length (Source), + Global => null; procedure Translate (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function); + Mapping : Maps.Character_Mapping_Function) + with + Post => Length (Source) = Length (Source)'Old, + Global => null; --------------------------------------- -- String Transformation Subprograms -- @@ -337,93 +491,204 @@ package Ada.Strings.Unbounded is (Source : Unbounded_String; Low : Positive; High : Natural; - By : String) return Unbounded_String; + By : String) return Unbounded_String + with + Pre => + Low - 1 <= Length (Source) + and then (if High >= Low + then Low - 1 + <= Natural'Last - By'Length + - Natural'Max (Length (Source) - High, 0) + else Length (Source) <= Natural'Last - By'Length), + Contract_Cases => + (High >= Low => + Length (Replace_Slice'Result) + = Low - 1 + By'Length + Natural'Max (Length (Source)'Old - High, 0), + others => + Length (Replace_Slice'Result) = Length (Source)'Old + By'Length), + Global => null; procedure Replace_Slice (Source : in out Unbounded_String; Low : Positive; High : Natural; - By : String); + By : String) + with + Pre => + Low - 1 <= Length (Source) + and then (if High >= Low + then Low - 1 + <= Natural'Last - By'Length + - Natural'Max (Length (Source) - High, 0) + else Length (Source) <= Natural'Last - By'Length), + Contract_Cases => + (High >= Low => + Length (Source) + = Low - 1 + By'Length + Natural'Max (Length (Source)'Old - High, 0), + others => + Length (Source) = Length (Source)'Old + By'Length), + Global => null; function Insert (Source : Unbounded_String; Before : Positive; - New_Item : String) return Unbounded_String; + New_Item : String) return Unbounded_String + with + Pre => Before - 1 <= Length (Source) + and then New_Item'Length <= Natural'Last - Length (Source), + Post => Length (Insert'Result) = Length (Source) + New_Item'Length, + Global => null; procedure Insert (Source : in out Unbounded_String; Before : Positive; - New_Item : String); + New_Item : String) + with + Pre => Before - 1 <= Length (Source) + and then New_Item'Length <= Natural'Last - Length (Source), + Post => Length (Source) = Length (Source)'Old + New_Item'Length, + Global => null; function Overwrite (Source : Unbounded_String; Position : Positive; - New_Item : String) return Unbounded_String; + New_Item : String) return Unbounded_String + with + Pre => Position - 1 <= Length (Source) + and then (if New_Item'Length /= 0 + then + New_Item'Length <= Natural'Last - (Position - 1)), + Post => + Length (Overwrite'Result) + = Natural'Max (Length (Source), Position - 1 + New_Item'Length), + Global => null; procedure Overwrite (Source : in out Unbounded_String; Position : Positive; - New_Item : String); + New_Item : String) + with + Pre => Position - 1 <= Length (Source) + and then (if New_Item'Length /= 0 + then + New_Item'Length <= Natural'Last - (Position - 1)), + Post => + Length (Source) + = Natural'Max (Length (Source)'Old, Position - 1 + New_Item'Length), + + Global => null; function Delete (Source : Unbounded_String; From : Positive; - Through : Natural) return Unbounded_String; + Through : Natural) return Unbounded_String + with + Pre => (if Through <= From then From - 1 <= Length (Source)), + Contract_Cases => + (Through >= From => + Length (Delete'Result) = Length (Source) - (Through - From + 1), + others => + Length (Delete'Result) = Length (Source)), + Global => null; procedure Delete (Source : in out Unbounded_String; From : Positive; - Through : Natural); + Through : Natural) + with + Pre => (if Through <= From then From - 1 <= Length (Source)), + Contract_Cases => + (Through >= From => + Length (Source) = Length (Source)'Old - (Through - From + 1), + others => + Length (Source) = Length (Source)'Old), + Global => null; function Trim (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String; + Side : Trim_End) return Unbounded_String + with + Post => Length (Trim'Result) <= Length (Source), + Global => null; procedure Trim (Source : in out Unbounded_String; - Side : Trim_End); + Side : Trim_End) + with + Post => Length (Source) <= Length (Source)'Old, + Global => null; function Trim (Source : Unbounded_String; Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String; + Right : Maps.Character_Set) return Unbounded_String + with + Post => Length (Trim'Result) <= Length (Source), + Global => null; procedure Trim (Source : in out Unbounded_String; Left : Maps.Character_Set; - Right : Maps.Character_Set); + Right : Maps.Character_Set) + with + Post => Length (Source) <= Length (Source)'Old, + Global => null; function Head (Source : Unbounded_String; Count : Natural; - Pad : Character := Space) return Unbounded_String; + Pad : Character := Space) return Unbounded_String + with + Post => Length (Head'Result) = Count, + Global => null; procedure Head (Source : in out Unbounded_String; Count : Natural; - Pad : Character := Space); + Pad : Character := Space) + with + Post => Length (Source) = Count, + Global => null; function Tail (Source : Unbounded_String; Count : Natural; - Pad : Character := Space) return Unbounded_String; + Pad : Character := Space) return Unbounded_String + with + Post => Length (Tail'Result) = Count, + Global => null; procedure Tail (Source : in out Unbounded_String; Count : Natural; - Pad : Character := Space); + Pad : Character := Space) + with + Post => Length (Source) = Count, + Global => null; function "*" (Left : Natural; - Right : Character) return Unbounded_String; + Right : Character) return Unbounded_String + with + Pre => Left <= Natural'Last, + Post => Length ("*"'Result) = Left, + Global => null; function "*" (Left : Natural; - Right : String) return Unbounded_String; + Right : String) return Unbounded_String + with + Pre => (if Left /= 0 then Right'Length <= Natural'Last / Left), + Post => Length ("*"'Result) = Left * Right'Length, + Global => null; function "*" (Left : Natural; - Right : Unbounded_String) return Unbounded_String; + Right : Unbounded_String) return Unbounded_String + with + Pre => (if Left /= 0 then Length (Right) <= Natural'Last / Left), + Post => Length ("*"'Result) = Left * Length (Right), + Global => null; private pragma Inline (Length); diff --git a/gcc/ada/libgnat/a-textio.adb b/gcc/ada/libgnat/a-textio.adb index 5b6e28a..276be12 100644 --- a/gcc/ada/libgnat/a-textio.adb +++ b/gcc/ada/libgnat/a-textio.adb @@ -43,7 +43,18 @@ with Ada.Unchecked_Deallocation; pragma Elaborate_All (System.File_IO); -- Needed because of calls to Chain_File in package body elaboration -package body Ada.Text_IO is +package body Ada.Text_IO with + Refined_State => (File_System => (Standard_In, + Standard_Out, + Standard_Err, + Current_In, + Current_Out, + Current_Err, + In_Name, + Out_Name, + Err_Name, + WC_Encoding)) +is package FIO renames System.File_IO; diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads index 32bbc6c..a2e1daf 100644 --- a/gcc/ada/libgnat/a-textio.ads +++ b/gcc/ada/libgnat/a-textio.ads @@ -33,6 +33,14 @@ -- -- ------------------------------------------------------------------------------ +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced by +-- setting the corresponding assertion policy to Ignore. These preconditions +-- are partial and protect against Status_Error, Mode_Error, and Layout_Error, +-- but not against other types of errors. + +pragma Assertion_Policy (Pre => Ignore); + -- Note: the generic subpackages of Text_IO (Integer_IO, Float_IO, Fixed_IO, -- Modular_IO, Decimal_IO and Enumeration_IO) appear as private children in -- GNAT. These children are with'ed automatically if they are referenced, so @@ -46,10 +54,15 @@ with System; with System.File_Control_Block; with System.WCh_Con; -package Ada.Text_IO is +package Ada.Text_IO with + Abstract_State => (File_System), + Initializes => (File_System), + Initial_Condition => Line_Length = 0 and Page_Length = 0 +is pragma Elaborate_Body; - type File_Type is limited private with Default_Initial_Condition; + type File_Type is limited private with + Default_Initial_Condition => (not Is_Open (File_Type)); type File_Mode is (In_File, Out_File, Append_File); -- The following representation clause allows the use of unchecked @@ -87,50 +100,97 @@ package Ada.Text_IO is (File : in out File_Type; Mode : File_Mode := Out_File; Name : String := ""; - Form : String := ""); + Form : String := "") + with + Pre => not Is_Open (File), + Post => + Is_Open (File) + and then Ada.Text_IO.Mode (File) = Mode + and then (if Mode /= In_File + then (Line_Length (File) = 0 + and then Page_Length (File) = 0)), + Global => (In_Out => File_System); procedure Open (File : in out File_Type; Mode : File_Mode; Name : String; - Form : String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - procedure Reset (File : in out File_Type; Mode : File_Mode); - procedure Reset (File : in out File_Type); - - function Mode (File : File_Type) return File_Mode; - function Name (File : File_Type) return String; - function Form (File : File_Type) return String; - - function Is_Open (File : File_Type) return Boolean; + Form : String := "") + with + Pre => not Is_Open (File), + Post => + Is_Open (File) + and then Ada.Text_IO.Mode (File) = Mode + and then (if Mode /= In_File + then (Line_Length (File) = 0 + and then Page_Length (File) = 0)), + Global => (In_Out => File_System); + + procedure Close (File : in out File_Type) with + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System); + procedure Delete (File : in out File_Type) with + Pre => Is_Open (File), + Post => not Is_Open (File), + Global => (In_Out => File_System); + procedure Reset (File : in out File_Type; Mode : File_Mode) with + Pre => Is_Open (File), + Post => + Is_Open (File) + and then Ada.Text_IO.Mode (File) = Mode + and then (if Mode /= In_File + then (Line_Length (File) = 0 + and then Page_Length (File) = 0)), + Global => (In_Out => File_System); + procedure Reset (File : in out File_Type) with + Pre => Is_Open (File), + Post => + Is_Open (File) + and Mode (File)'Old = Mode (File) + and (if Mode (File) /= In_File + then (Line_Length (File) = 0 + and then Page_Length (File) = 0)), + Global => (In_Out => File_System); + + function Mode (File : File_Type) return File_Mode with + Pre => Is_Open (File), + Global => null; + function Name (File : File_Type) return String with + Pre => Is_Open (File), + Global => null; + function Form (File : File_Type) return String with + Pre => Is_Open (File), + Global => null; + + function Is_Open (File : File_Type) return Boolean with + Global => null; ------------------------------------------------------ -- Control of default input, output and error files -- ------------------------------------------------------ - procedure Set_Input (File : File_Type); - procedure Set_Output (File : File_Type); - procedure Set_Error (File : File_Type); + procedure Set_Input (File : File_Type) with SPARK_Mode => Off; + procedure Set_Output (File : File_Type) with SPARK_Mode => Off; + procedure Set_Error (File : File_Type) with SPARK_Mode => Off; - function Standard_Input return File_Type; - function Standard_Output return File_Type; - function Standard_Error return File_Type; + function Standard_Input return File_Type with SPARK_Mode => Off; + function Standard_Output return File_Type with SPARK_Mode => Off; + function Standard_Error return File_Type with SPARK_Mode => Off; - function Current_Input return File_Type; - function Current_Output return File_Type; - function Current_Error return File_Type; + function Current_Input return File_Type with SPARK_Mode => Off; + function Current_Output return File_Type with SPARK_Mode => Off; + function Current_Error return File_Type with SPARK_Mode => Off; type File_Access is access constant File_Type; - function Standard_Input return File_Access; - function Standard_Output return File_Access; - function Standard_Error return File_Access; + function Standard_Input return File_Access with SPARK_Mode => Off; + function Standard_Output return File_Access with SPARK_Mode => Off; + function Standard_Error return File_Access with SPARK_Mode => Off; - function Current_Input return File_Access; - function Current_Output return File_Access; - function Current_Error return File_Access; + function Current_Input return File_Access with SPARK_Mode => Off; + function Current_Output return File_Access with SPARK_Mode => Off; + function Current_Error return File_Access with SPARK_Mode => Off; -------------------- -- Buffer control -- @@ -139,129 +199,319 @@ package Ada.Text_IO is -- Note: The parameter file is IN OUT in the RM, but this is clearly -- an oversight, and was intended to be IN, see AI95-00057. - procedure Flush (File : File_Type); - procedure Flush; + procedure Flush (File : File_Type) with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); + procedure Flush with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- - procedure Set_Line_Length (File : File_Type; To : Count); - procedure Set_Line_Length (To : Count); - - procedure Set_Page_Length (File : File_Type; To : Count); - procedure Set_Page_Length (To : Count); - - function Line_Length (File : File_Type) return Count; - function Line_Length return Count; - - function Page_Length (File : File_Type) return Count; - function Page_Length return Count; + procedure Set_Line_Length (File : File_Type; To : Count) with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File) = To + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); + procedure Set_Line_Length (To : Count) with + Post => + Line_Length = To + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + + procedure Set_Page_Length (File : File_Type; To : Count) with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Page_Length (File) = To + and Line_Length (File)'Old = Line_Length (File), + Global => (In_Out => File_System); + procedure Set_Page_Length (To : Count) with + Post => + Page_Length = To + and Line_Length'Old = Line_Length, + Global => (In_Out => File_System); + + function Line_Length (File : File_Type) return Count with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); + function Line_Length return Count with + Global => (Input => File_System); + + function Page_Length (File : File_Type) return Count with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Global => (Input => File_System); + function Page_Length return Count with + Global => (Input => File_System); ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ - procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure New_Line (Spacing : Positive_Count := 1); - - procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure Skip_Line (Spacing : Positive_Count := 1); - - function End_Of_Line (File : File_Type) return Boolean; - function End_Of_Line return Boolean; - - procedure New_Page (File : File_Type); - procedure New_Page; - - procedure Skip_Page (File : File_Type); - procedure Skip_Page; - - function End_Of_Page (File : File_Type) return Boolean; - function End_Of_Page return Boolean; - - function End_Of_File (File : File_Type) return Boolean; - function End_Of_File return Boolean; - - procedure Set_Col (File : File_Type; To : Positive_Count); - procedure Set_Col (To : Positive_Count); - - procedure Set_Line (File : File_Type; To : Positive_Count); - procedure Set_Line (To : Positive_Count); - - function Col (File : File_Type) return Positive_Count; - function Col return Positive_Count; - - function Line (File : File_Type) return Positive_Count; - function Line return Positive_Count; - - function Page (File : File_Type) return Positive_Count; - function Page return Positive_Count; + procedure New_Line (File : File_Type; Spacing : Positive_Count := 1) with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); + procedure New_Line (Spacing : Positive_Count := 1) with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + + procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1) with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); + procedure Skip_Line (Spacing : Positive_Count := 1) with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + + function End_Of_Line (File : File_Type) return Boolean with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); + function End_Of_Line return Boolean with + Global => (Input => File_System); + + procedure New_Page (File : File_Type) with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); + procedure New_Page with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + + procedure Skip_Page (File : File_Type) with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); + procedure Skip_Page with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + + function End_Of_Page (File : File_Type) return Boolean with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); + function End_Of_Page return Boolean with + Global => (Input => File_System); + + function End_Of_File (File : File_Type) return Boolean with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); + function End_Of_File return Boolean with + Global => (Input => File_System); + + procedure Set_Col (File : File_Type; To : Positive_Count) with + Pre => + Is_Open (File) + and then (if Mode (File) /= In_File + then (Line_Length (File) = 0 + or else To <= Line_Length (File))), + Contract_Cases => + (Mode (File) /= In_File => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + others => True), + Global => (In_Out => File_System); + procedure Set_Col (To : Positive_Count) with + Pre => Line_Length = 0 or To <= Line_Length, + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + + procedure Set_Line (File : File_Type; To : Positive_Count) with + Pre => + Is_Open (File) + and then (if Mode (File) /= In_File + then (Page_Length (File) = 0 + or else To <= Page_Length (File))), + Contract_Cases => + (Mode (File) /= In_File => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + others => True), + Global => (In_Out => File_System); + procedure Set_Line (To : Positive_Count) with + Pre => Page_Length = 0 or To <= Page_Length, + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + + function Col (File : File_Type) return Positive_Count with + Pre => Is_Open (File), + Global => (Input => File_System); + function Col return Positive_Count with + Global => (Input => File_System); + + function Line (File : File_Type) return Positive_Count with + Pre => Is_Open (File), + Global => (Input => File_System); + function Line return Positive_Count with + Global => (Input => File_System); + + function Page (File : File_Type) return Positive_Count with + Pre => Is_Open (File), + Global => (Input => File_System); + function Page return Positive_Count with + Global => (Input => File_System); ---------------------------- -- Character Input-Output -- ---------------------------- - procedure Get (File : File_Type; Item : out Character); - procedure Get (Item : out Character); - procedure Put (File : File_Type; Item : Character); - procedure Put (Item : Character); + procedure Get (File : File_Type; Item : out Character) with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); + procedure Get (Item : out Character) with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + procedure Put (File : File_Type; Item : Character) with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); + procedure Put (Item : Character) with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Look_Ahead (File : File_Type; Item : out Character; - End_Of_Line : out Boolean); + End_Of_Line : out Boolean) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (Input => File_System); procedure Look_Ahead (Item : out Character; - End_Of_Line : out Boolean); + End_Of_Line : out Boolean) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (Input => File_System); procedure Get_Immediate (File : File_Type; - Item : out Character); + Item : out Character) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); procedure Get_Immediate - (Item : out Character); + (Item : out Character) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get_Immediate (File : File_Type; Item : out Character; - Available : out Boolean); + Available : out Boolean) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); procedure Get_Immediate (Item : out Character; - Available : out Boolean); + Available : out Boolean) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); ------------------------- -- String Input-Output -- ------------------------- - procedure Get (File : File_Type; Item : out String); - procedure Get (Item : out String); - procedure Put (File : File_Type; Item : String); - procedure Put (Item : String); + procedure Get (File : File_Type; Item : out String) with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); + procedure Get (Item : out String) with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); + procedure Put (File : File_Type; Item : String) with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); + procedure Put (Item : String) with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get_Line (File : File_Type; Item : out String; - Last : out Natural); + Last : out Natural) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Post => (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last + else Last = Item'First - 1), + Global => (In_Out => File_System); procedure Get_Line (Item : out String; - Last : out Natural); - - function Get_Line (File : File_Type) return String; + Last : out Natural) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length + and (if Item'Length > 0 then Last in Item'First - 1 .. Item'Last + else Last = Item'First - 1), + Global => (In_Out => File_System); + + function Get_Line (File : File_Type) return String with SPARK_Mode => Off; pragma Ada_05 (Get_Line); - function Get_Line return String; + function Get_Line return String with SPARK_Mode => Off; pragma Ada_05 (Get_Line); procedure Put_Line (File : File_Type; - Item : String); + Item : String) + with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); procedure Put_Line - (Item : String); + (Item : String) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); --------------------------------------- -- Generic packages for Input-Output -- @@ -447,14 +697,20 @@ private Standard_Out_AFCB : aliased Text_AFCB; Standard_Err_AFCB : aliased Text_AFCB; - Standard_In : aliased File_Type := Standard_In_AFCB'Access; - Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; - Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; + Standard_In : aliased File_Type := Standard_In_AFCB'Access with + Part_Of => File_System; + Standard_Out : aliased File_Type := Standard_Out_AFCB'Access with + Part_Of => File_System; + Standard_Err : aliased File_Type := Standard_Err_AFCB'Access with + Part_Of => File_System; -- Standard files - Current_In : aliased File_Type := Standard_In; - Current_Out : aliased File_Type := Standard_Out; - Current_Err : aliased File_Type := Standard_Err; + Current_In : aliased File_Type := Standard_In with + Part_Of => File_System; + Current_Out : aliased File_Type := Standard_Out with + Part_Of => File_System; + Current_Err : aliased File_Type := Standard_Err with + Part_Of => File_System; -- Current files function EOF_Char return Integer; diff --git a/gcc/ada/libgnat/a-tideio.ads b/gcc/ada/libgnat/a-tideio.ads index c504707..efe52c5 100644 --- a/gcc/ada/libgnat/a-tideio.ads +++ b/gcc/ada/libgnat/a-tideio.ads @@ -52,35 +52,58 @@ package Ada.Text_IO.Decimal_IO is procedure Get (File : File_Type; Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); procedure Get (Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Put (File : File_Type; Item : Num; Fore : Field := Default_Fore; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); procedure Put (Item : Num; Fore : Field := Default_Fore; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get (From : String; Item : out Num; - Last : out Positive); + Last : out Positive) + with + Global => null; procedure Put (To : out String; Item : Num; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Global => null; private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tienio.ads b/gcc/ada/libgnat/a-tienio.ads index 68f4694..fb80abd 100644 --- a/gcc/ada/libgnat/a-tienio.ads +++ b/gcc/ada/libgnat/a-tienio.ads @@ -28,28 +28,49 @@ package Ada.Text_IO.Enumeration_IO is Default_Width : Field := 0; Default_Setting : Type_Set := Upper_Case; - procedure Get (File : File_Type; Item : out Enum); - procedure Get (Item : out Enum); + procedure Get (File : File_Type; Item : out Enum) with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); + procedure Get (Item : out Enum) with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Put (File : File_Type; Item : Enum; Width : Field := Default_Width; - Set : Type_Set := Default_Setting); + Set : Type_Set := Default_Setting) + with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); procedure Put (Item : Enum; Width : Field := Default_Width; - Set : Type_Set := Default_Setting); + Set : Type_Set := Default_Setting) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get (From : String; Item : out Enum; - Last : out Positive); + Last : out Positive) + with + Global => null; procedure Put (To : out String; Item : Enum; - Set : Type_Set := Default_Setting); + Set : Type_Set := Default_Setting) + with + Global => null; end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-tifiio.ads b/gcc/ada/libgnat/a-tifiio.ads index 265600db..1acf67a 100644 --- a/gcc/ada/libgnat/a-tifiio.ads +++ b/gcc/ada/libgnat/a-tifiio.ads @@ -32,35 +32,58 @@ package Ada.Text_IO.Fixed_IO is procedure Get (File : File_Type; Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); procedure Get (Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Put (File : File_Type; Item : Num; Fore : Field := Default_Fore; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); procedure Put (Item : Num; Fore : Field := Default_Fore; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get (From : String; Item : out Num; - Last : out Positive); + Last : out Positive) + with + Global => null; procedure Put (To : out String; Item : Num; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Global => null; private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads index dcc4856..16e65a5 100644 --- a/gcc/ada/libgnat/a-tiflio.ads +++ b/gcc/ada/libgnat/a-tiflio.ads @@ -52,35 +52,58 @@ package Ada.Text_IO.Float_IO is procedure Get (File : File_Type; Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); procedure Get (Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Put (File : File_Type; Item : Num; Fore : Field := Default_Fore; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); procedure Put (Item : Num; Fore : Field := Default_Fore; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get (From : String; Item : out Num; - Last : out Positive); + Last : out Positive) + with + Global => null; procedure Put (To : out String; Item : Num; Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + Exp : Field := Default_Exp) + with + Global => null; private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-tiinio.ads b/gcc/ada/libgnat/a-tiinio.ads index 429f3b1..28f8d54 100644 --- a/gcc/ada/libgnat/a-tiinio.ads +++ b/gcc/ada/libgnat/a-tiinio.ads @@ -51,32 +51,55 @@ package Ada.Text_IO.Integer_IO is procedure Get (File : File_Type; Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); procedure Get (Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Put (File : File_Type; Item : Num; Width : Field := Default_Width; - Base : Number_Base := Default_Base); + Base : Number_Base := Default_Base) + with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); procedure Put (Item : Num; Width : Field := Default_Width; - Base : Number_Base := Default_Base); + Base : Number_Base := Default_Base) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get (From : String; Item : out Num; - Last : out Positive); + Last : out Positive) + with + Global => null; procedure Put (To : out String; Item : Num; - Base : Number_Base := Default_Base); + Base : Number_Base := Default_Base) + with + Global => null; private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-timoio.ads b/gcc/ada/libgnat/a-timoio.ads index 5b8a72e..2d1ab91 100644 --- a/gcc/ada/libgnat/a-timoio.ads +++ b/gcc/ada/libgnat/a-timoio.ads @@ -51,32 +51,55 @@ package Ada.Text_IO.Modular_IO is procedure Get (File : File_Type; Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Pre => Is_Open (File) and then Mode (File) = In_File, + Global => (In_Out => File_System); procedure Get (Item : out Num; - Width : Field := 0); + Width : Field := 0) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Put (File : File_Type; Item : Num; Width : Field := Default_Width; - Base : Number_Base := Default_Base); + Base : Number_Base := Default_Base) + with + Pre => Is_Open (File) and then Mode (File) /= In_File, + Post => + Line_Length (File)'Old = Line_Length (File) + and Page_Length (File)'Old = Page_Length (File), + Global => (In_Out => File_System); procedure Put (Item : Num; Width : Field := Default_Width; - Base : Number_Base := Default_Base); + Base : Number_Base := Default_Base) + with + Post => + Line_Length'Old = Line_Length + and Page_Length'Old = Page_Length, + Global => (In_Out => File_System); procedure Get (From : String; Item : out Num; - Last : out Positive); + Last : out Positive) + with + Global => null; procedure Put (To : out String; Item : Num; - Base : Number_Base := Default_Base); + Base : Number_Base := Default_Base) + with + Global => null; private pragma Inline (Get); diff --git a/gcc/ada/libgnat/a-wichha.ads b/gcc/ada/libgnat/a-wichha.ads index 583308e..a906e02 100644 --- a/gcc/ada/libgnat/a-wichha.ads +++ b/gcc/ada/libgnat/a-wichha.ads @@ -25,28 +25,28 @@ package Ada.Wide_Characters.Handling is function Is_Control (Item : Wide_Character) return Boolean; pragma Inline (Is_Control); -- Returns True if the Wide_Character designated by Item is categorized as - -- other_control, otherwise returns false. + -- other_control, otherwise returns False. function Is_Letter (Item : Wide_Character) return Boolean; pragma Inline (Is_Letter); -- Returns True if the Wide_Character designated by Item is categorized as -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, - -- letter_other, or number_letter. Otherwise returns false. + -- letter_other, or number_letter. Otherwise returns False. function Is_Lower (Item : Wide_Character) return Boolean; pragma Inline (Is_Lower); -- Returns True if the Wide_Character designated by Item is categorized as - -- letter_lowercase, otherwise returns false. + -- letter_lowercase, otherwise returns False. function Is_Upper (Item : Wide_Character) return Boolean; pragma Inline (Is_Upper); -- Returns True if the Wide_Character designated by Item is categorized as - -- letter_uppercase, otherwise returns false. + -- letter_uppercase, otherwise returns False. function Is_Digit (Item : Wide_Character) return Boolean; pragma Inline (Is_Digit); -- Returns True if the Wide_Character designated by Item is categorized as - -- number_decimal, otherwise returns false. + -- number_decimal, otherwise returns False. function Is_Decimal_Digit (Item : Wide_Character) return Boolean renames Is_Digit; @@ -54,51 +54,51 @@ package Ada.Wide_Characters.Handling is function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean; -- Returns True if the Wide_Character designated by Item is categorized as -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise - -- returns false. + -- returns False. function Is_Alphanumeric (Item : Wide_Character) return Boolean; pragma Inline (Is_Alphanumeric); -- Returns True if the Wide_Character designated by Item is categorized as - -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise - -- returns false. + -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, + -- letter_other, number_letter, or number_decimal; otherwise returns False. function Is_Special (Item : Wide_Character) return Boolean; pragma Inline (Is_Special); -- Returns True if the Wide_Character designated by Item is categorized -- as graphic_character, but not categorized as letter_uppercase, -- letter_lowercase, letter_titlecase, letter_modifier, letter_other, - -- number_letter, or number_decimal. Otherwise returns false. + -- number_letter, or number_decimal. Otherwise returns False. function Is_Line_Terminator (Item : Wide_Character) return Boolean; pragma Inline (Is_Line_Terminator); -- Returns True if the Wide_Character designated by Item is categorized as -- separator_line or separator_paragraph, or if Item is a conventional line - -- terminator character (CR, LF, VT, or FF). Otherwise returns false. + -- terminator character (CR, LF, VT, or FF). Otherwise returns False. function Is_Mark (Item : Wide_Character) return Boolean; pragma Inline (Is_Mark); -- Returns True if the Wide_Character designated by Item is categorized as - -- mark_non_spacing or mark_spacing_combining, otherwise returns false. + -- mark_non_spacing or mark_spacing_combining, otherwise returns False. function Is_Other_Format (Item : Wide_Character) return Boolean; pragma Inline (Is_Other_Format); -- Returns True if the Wide_Character designated by Item is categorized as - -- other_format, otherwise returns false. + -- other_format, otherwise returns False. function Is_Punctuation_Connector (Item : Wide_Character) return Boolean; pragma Inline (Is_Punctuation_Connector); -- Returns True if the Wide_Character designated by Item is categorized as - -- punctuation_connector, otherwise returns false. + -- punctuation_connector, otherwise returns False. function Is_Space (Item : Wide_Character) return Boolean; pragma Inline (Is_Space); -- Returns True if the Wide_Character designated by Item is categorized as - -- separator_space, otherwise returns false. + -- separator_space, otherwise returns False. function Is_Graphic (Item : Wide_Character) return Boolean; pragma Inline (Is_Graphic); -- Returns True if the Wide_Character designated by Item is categorized as - -- graphic_character, otherwise returns false. + -- graphic_character, otherwise returns False. function To_Lower (Item : Wide_Character) return Wide_Character; pragma Inline (To_Lower); diff --git a/gcc/ada/libgnat/g-brapre.ads b/gcc/ada/libgnat/g-brapre.ads new file mode 100644 index 0000000..9b88e35 --- /dev/null +++ b/gcc/ada/libgnat/g-brapre.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B R A N C H _ P R E D I C T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2019, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines giving hints to the branch predictor of the +-- code generator. These hints are useful when optimization is enabled and the +-- branch probability heuristics are used (which is the default), but they are +-- overridden when profile feedback-directed optimization is used instead. + +-- The canonical pattern is to use them as the condition of an If statement: +-- +-- if Likely (X > 0) then +-- Do_Something; +-- end if; +-- +-- when it is not obvious that one outcome of the condition is more likely +-- than the other, or else to reverse the prediction made by the heuristics +-- in very peculiar cases. In the other cases, it is better not to use them, +-- because predicting how programs actually perform is notoriously hard. + +package GNAT.Branch_Prediction is + pragma Pure; + + function Expect (Condition : Boolean; Outcome : Boolean) return Boolean; + pragma Import (Intrinsic, Expect, "__builtin_expect"); + -- This function returns the value of its first parameter Condition and + -- tells the branch predictor that this value is expected to be Outcome. + + function Likely (Condition : Boolean) return Boolean; + pragma Import (Intrinsic, Likely, "__builtin_likely"); + -- This function returns the value of its parameter Condition and tells + -- the branch predictor that this value is expected to be True. Calling + -- it is strictly equivalent to calling Expect with Outcome set to True. + + function Unlikely (Condition : Boolean) return Boolean; + pragma Import (Intrinsic, Unlikely, "__builtin_unlikely"); + -- This function returns the value of its parameter Condition and tells + -- the branch predictor that this value is expected to be False. Calling + -- it is strictly equivalent to calling Expect with Outcome set to False. + +end GNAT.Branch_Prediction; diff --git a/gcc/ada/libgnat/g-comlin.adb b/gcc/ada/libgnat/g-comlin.adb index 0f527c6..29100af 100644 --- a/gcc/ada/libgnat/g-comlin.adb +++ b/gcc/ada/libgnat/g-comlin.adb @@ -443,7 +443,7 @@ package body GNAT.Command_Line is Parser.Current_Argument := Parser.Current_Argument + 1; - -- Could it be a file name with wild cards to expand? + -- Could it be a file name with wildcards to expand? if Do_Expansion then declare diff --git a/gcc/ada/libgnat/g-comlin.ads b/gcc/ada/libgnat/g-comlin.ads index 8306f9a..f1251b6 100644 --- a/gcc/ada/libgnat/g-comlin.ads +++ b/gcc/ada/libgnat/g-comlin.ads @@ -466,9 +466,9 @@ package GNAT.Command_Line is -- function should not be called before Getopt has returned ASCII.NUL. -- -- If Do_Expansion is True, then the parameter on the command line will - -- be considered as a filename with wild cards, and will be expanded. The + -- be considered as a filename with wildcards, and will be expanded. The -- matching file names will be returned one at a time. This is useful in - -- non-Unix systems for obtaining normal expansion of wild card references. + -- non-Unix systems for obtaining normal expansion of wildcard references. -- When there are no more arguments on the command line, this function -- returns an empty string. @@ -515,7 +515,7 @@ package GNAT.Command_Line is Pattern : String; Directory : String := ""; Basic_Regexp : Boolean := True); - -- Initialize a wild card expansion. The next calls to Expansion will + -- Initialize a wildcard expansion. The next calls to Expansion will -- return the next file name in Directory which match Pattern (Pattern -- is a regular expression, using only the Unix shell and DOS syntax if -- Basic_Regexp is True). When Directory is an empty string, the current diff --git a/gcc/ada/libgnat/g-encstr.adb b/gcc/ada/libgnat/g-encstr.adb index 81a73fd..b115c8a 100644 --- a/gcc/ada/libgnat/g-encstr.adb +++ b/gcc/ada/libgnat/g-encstr.adb @@ -79,12 +79,12 @@ package body GNAT.Encode_String is Ptr : Natural; begin - Ptr := S'First; + Ptr := Result'First; for J in S'Range loop Encode_Wide_Character (S (J), Result, Ptr); end loop; - Length := Ptr - S'First; + Length := Ptr - Result'First; end Encode_Wide_String; ----------------------------- @@ -108,12 +108,12 @@ package body GNAT.Encode_String is Ptr : Natural; begin - Ptr := S'First; + Ptr := Result'First; for J in S'Range loop Encode_Wide_Wide_Character (S (J), Result, Ptr); end loop; - Length := Ptr - S'First; + Length := Ptr - Result'First; end Encode_Wide_Wide_String; --------------------------- diff --git a/gcc/ada/libgnat/g-exptty.adb b/gcc/ada/libgnat/g-exptty.adb index 1a977b5..728c5c6 100644 --- a/gcc/ada/libgnat/g-exptty.adb +++ b/gcc/ada/libgnat/g-exptty.adb @@ -38,6 +38,28 @@ package body GNAT.Expect.TTY is On_Windows : constant Boolean := Directory_Separator = '\'; -- True when on Windows + function Waitpid (Process : System.Address; Blocking : Integer) + return Integer; + pragma Import (C, Waitpid, "__gnat_tty_waitpid"); + -- Wait for a specific process id, and return its exit code + + ------------------------ + -- Is_Process_Running -- + ------------------------ + + function Is_Process_Running + (Descriptor : in out TTY_Process_Descriptor) + return Boolean + is + begin + if Descriptor.Process = System.Null_Address then + return False; + end if; + + Descriptor.Exit_Status := Waitpid (Descriptor.Process, Blocking => 0); + return Descriptor.Exit_Status = Still_Active; + end Is_Process_Running; + ----------- -- Close -- ----------- @@ -49,10 +71,6 @@ package body GNAT.Expect.TTY is procedure Terminate_Process (Process : System.Address); pragma Import (C, Terminate_Process, "__gnat_terminate_process"); - function Waitpid (Process : System.Address) return Integer; - pragma Import (C, Waitpid, "__gnat_tty_waitpid"); - -- Wait for a specific process id, and return its exit code - procedure Free_Process (Process : System.Address); pragma Import (C, Free_Process, "__gnat_free_process"); @@ -63,7 +81,7 @@ package body GNAT.Expect.TTY is -- If we haven't already closed the process if Descriptor.Process = System.Null_Address then - Status := -1; + Status := Descriptor.Exit_Status; else -- Send a Ctrl-C to the process first. This way, if the launched @@ -75,9 +93,6 @@ package body GNAT.Expect.TTY is -- signal, so this needs to be done while the file descriptors are -- still open (it used to be after the closes and that was wrong). - Interrupt (Descriptor); - delay (0.05); - if Descriptor.Input_Fd /= Invalid_FD then Close (Descriptor.Input_Fd); end if; @@ -92,8 +107,23 @@ package body GNAT.Expect.TTY is Close (Descriptor.Output_Fd); end if; - Terminate_Process (Descriptor.Process); - Status := Waitpid (Descriptor.Process); + if Descriptor.Exit_Status = Still_Active then + Status := Waitpid (Descriptor.Process, Blocking => 0); + + if Status = Still_Active then + -- In theory the process might hav died since the check. In + -- practice the following calls should not cause any issue. + Interrupt (Descriptor); + delay (0.05); + Terminate_Process (Descriptor.Process); + Status := Waitpid (Descriptor.Process, Blocking => 1); + Descriptor.Exit_Status := Status; + end if; + else + -- If Exit_Status is not STILL_ACTIVE just retrieve the saved + -- exit status + Status := Descriptor.Exit_Status; + end if; if not On_Windows then Close_TTY (Descriptor.Process); @@ -258,6 +288,7 @@ package body GNAT.Expect.TTY is pragma Import (C, Internal, "__gnat_setup_communication"); begin + Pid.Exit_Status := Still_Active; if Internal (Pid.Process'Address) /= 0 then raise Invalid_Process with "cannot setup communication."; end if; diff --git a/gcc/ada/libgnat/g-exptty.ads b/gcc/ada/libgnat/g-exptty.ads index 3a90d8d..57aa8d7 100644 --- a/gcc/ada/libgnat/g-exptty.ads +++ b/gcc/ada/libgnat/g-exptty.ads @@ -92,6 +92,11 @@ package GNAT.Expect.TTY is Columns : Natural); -- Sets up the size of the terminal as reported to the spawned process + function Is_Process_Running + (Descriptor : in out TTY_Process_Descriptor) + return Boolean; + -- Return True is the process is still alive + private -- All declarations in the private part must be fully commented ??? @@ -129,9 +134,14 @@ private Cmd : String; Args : System.Address); + Still_Active : constant Integer := -1; + type TTY_Process_Descriptor is new Process_Descriptor with record - Process : System.Address; -- Underlying structure used in C - Use_Pipes : Boolean := True; + Process : System.Address; + -- Underlying structure used in C + Exit_Status : Integer := Still_Active; + -- Hold the exit status of the process. + Use_Pipes : Boolean := True; end record; end GNAT.Expect.TTY; diff --git a/gcc/ada/libgnat/g-lists.adb b/gcc/ada/libgnat/g-lists.adb index f7447a5..817274a 100644 --- a/gcc/ada/libgnat/g-lists.adb +++ b/gcc/ada/libgnat/g-lists.adb @@ -337,6 +337,57 @@ package body GNAT.Lists is end if; end Ensure_Unlocked; + ----------- + -- Equal -- + ----------- + + function Equal + (Left : Doubly_Linked_List; + Right : Doubly_Linked_List) return Boolean + is + Left_Head : Node_Ptr; + Left_Nod : Node_Ptr; + Right_Head : Node_Ptr; + Right_Nod : Node_Ptr; + + begin + -- Two non-existent lists are considered equal + + if Left = Nil and then Right = Nil then + return True; + + -- A non-existent list is never equal to an already created list + + elsif Left = Nil or else Right = Nil then + return False; + + -- The two lists must contain the same number of elements to be equal + + elsif Size (Left) /= Size (Right) then + return False; + end if; + + -- Compare the two lists element by element + + Left_Head := Left.Nodes'Access; + Left_Nod := Left_Head.Next; + Right_Head := Right.Nodes'Access; + Right_Nod := Right_Head.Next; + while Is_Valid (Left_Nod, Left_Head) + and then + Is_Valid (Right_Nod, Right_Head) + loop + if Left_Nod.Elem /= Right_Nod.Elem then + return False; + end if; + + Left_Nod := Left_Nod.Next; + Right_Nod := Right_Nod.Next; + end loop; + + return True; + end Equal; + --------------- -- Find_Node -- --------------- diff --git a/gcc/ada/libgnat/g-lists.ads b/gcc/ada/libgnat/g-lists.ads index b64ef08..fdcaed6 100644 --- a/gcc/ada/libgnat/g-lists.ads +++ b/gcc/ada/libgnat/g-lists.ads @@ -117,6 +117,12 @@ package GNAT.Lists is -- end of a list's lifetime. This action will raise Iterated if the -- list has outstanding iterators. + function Equal + (Left : Doubly_Linked_List; + Right : Doubly_Linked_List) return Boolean; + -- Determine whether lists Left and Right have the same characteristics + -- and contain the same elements. + function First (L : Doubly_Linked_List) return Element_Type; -- Obtain an element from the start of list L. This action will raise -- List_Empty if the list is empty. diff --git a/gcc/ada/libgnat/g-regexp.ads b/gcc/ada/libgnat/g-regexp.ads index 50c992d..162738b 100644 --- a/gcc/ada/libgnat/g-regexp.ads +++ b/gcc/ada/libgnat/g-regexp.ads @@ -50,7 +50,7 @@ -- matching with the restriction that it matches entire strings. It -- is particularly useful for file name matching, and in particular -- it provides "globbing patterns" that are useful in implementing --- unix or DOS style wild card matching for file names. +-- unix or DOS style wildcard matching for file names. -- GNAT.Regpat (files g-regpat.ads/s-regpat.ads/g-regpat.adb) -- This is a more complete implementation of Unix-style regular diff --git a/gcc/ada/libgnat/g-regpat.ads b/gcc/ada/libgnat/g-regpat.ads index bac4d74..62fc2e8 100644 --- a/gcc/ada/libgnat/g-regpat.ads +++ b/gcc/ada/libgnat/g-regpat.ads @@ -53,7 +53,7 @@ -- matching with the restriction that it matches entire strings. It -- is particularly useful for file name matching, and in particular -- it provides "globbing patterns" that are useful in implementing --- unix or DOS style wild card matching for file names. +-- unix or DOS style wildcard matching for file names. -- GNAT.Regpat (files g-regpat.ads/s-regpat.ads/s-regpat.adb) -- This is a more complete implementation of Unix-style regular diff --git a/gcc/ada/libgnat/g-sercom.adb b/gcc/ada/libgnat/g-sercom.adb index c3bed83..ccf5239 100644 --- a/gcc/ada/libgnat/g-sercom.adb +++ b/gcc/ada/libgnat/g-sercom.adb @@ -103,6 +103,15 @@ package body GNAT.Serial_Communications is Unimplemented; end Read; + ------------ + -- To_Ada -- + ------------ + + procedure To_Ada (Port : out Serial_Port; Fd : Serial_Port_Descriptor) is + begin + Unimplemented; + end To_Ada; + ----------- -- Write -- ----------- diff --git a/gcc/ada/libgnat/g-sercom.ads b/gcc/ada/libgnat/g-sercom.ads index 8550e8d..52447db 100644 --- a/gcc/ada/libgnat/g-sercom.ads +++ b/gcc/ada/libgnat/g-sercom.ads @@ -33,6 +33,7 @@ with Ada.Streams; with Interfaces.C; +with System.OS_Constants; package GNAT.Serial_Communications is @@ -100,8 +101,13 @@ package GNAT.Serial_Communications is -- cases, an explicit port name can be passed directly to Open. type Data_Rate is - (B75, B110, B150, B300, B600, B1200, B2400, B4800, B9600, - B19200, B38400, B57600, B115200); + (B75, B110, B150, B300, B600, B1200, + B2400, B4800, B9600, + B19200, B38400, B57600, B115200, + B230400, B460800, B500000, B576000, B921600, + B1000000, B1152000, B1500000, + B2000000, B2500000, B3000000, + B3500000, B4000000); -- Speed of the communication type Data_Bits is (CS8, CS7); @@ -117,6 +123,11 @@ package GNAT.Serial_Communications is -- No flow control, hardware flow control, software flow control type Serial_Port is new Ada.Streams.Root_Stream_Type with private; + -- Serial port stream type + + type Serial_Port_Descriptor is + new System.OS_Constants.Serial_Port_Descriptor; + -- OS specific serial port descriptor procedure Open (Port : out Serial_Port; @@ -163,28 +174,52 @@ package GNAT.Serial_Communications is procedure Close (Port : in out Serial_Port); -- Close port -private + procedure To_Ada (Port : out Serial_Port; Fd : Serial_Port_Descriptor) + with Inline; + -- Convert a serial port descriptor to Serial_Port. This is useful when a + -- serial port descriptor is obtained from an external library call. - type Port_Data; - type Port_Data_Access is access Port_Data; + function To_C + (Port : Serial_Port) return Serial_Port_Descriptor with Inline; + -- Return a serial port descriptor to be used by external subprograms. + -- This is useful for C functions that are not yet interfaced in this + -- package. + +private type Serial_Port is new Ada.Streams.Root_Stream_Type with record - H : Port_Data_Access; + H : Serial_Port_Descriptor := -1; end record; Data_Rate_Value : constant array (Data_Rate) of Interfaces.C.unsigned := - (B75 => 75, - B110 => 110, - B150 => 150, - B300 => 300, - B600 => 600, - B1200 => 1_200, - B2400 => 2_400, - B4800 => 4_800, - B9600 => 9_600, - B19200 => 19_200, - B38400 => 38_400, - B57600 => 57_600, - B115200 => 115_200); + (B75 => 75, + B110 => 110, + B150 => 150, + B300 => 300, + B600 => 600, + B1200 => 1_200, + B2400 => 2_400, + B4800 => 4_800, + B9600 => 9_600, + B19200 => 19_200, + B38400 => 38_400, + B57600 => 57_600, + B115200 => 115_200, + B230400 => 230_400, + B460800 => 460_800, + B500000 => 500_000, + B576000 => 576_000, + B921600 => 921_600, + B1000000 => 1_000_000, + B1152000 => 1_152_000, + B1500000 => 1_500_000, + B2000000 => 2_000_000, + B2500000 => 2_500_000, + B3000000 => 3_000_000, + B3500000 => 3_500_000, + B4000000 => 4_000_000); + + function To_C (Port : Serial_Port) return Serial_Port_Descriptor is + (Port.H); end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sercom__linux.adb b/gcc/ada/libgnat/g-sercom__linux.adb index 93bc793..87143e2 100644 --- a/gcc/ada/libgnat/g-sercom__linux.adb +++ b/gcc/ada/libgnat/g-sercom__linux.adb @@ -33,12 +33,10 @@ with Ada.Streams; use Ada.Streams; with Ada; use Ada; -with Ada.Unchecked_Deallocation; with System; use System; with System.Communication; use System.Communication; with System.CRTL; use System.CRTL; -with System.OS_Constants; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -48,8 +46,6 @@ package body GNAT.Serial_Communications is use type Interfaces.C.unsigned; - type Port_Data is new int; - subtype unsigned is Interfaces.C.unsigned; subtype char is Interfaces.C.char; subtype unsigned_char is Interfaces.C.unsigned_char; @@ -58,19 +54,32 @@ package body GNAT.Serial_Communications is pragma Import (C, fcntl, "fcntl"); C_Data_Rate : constant array (Data_Rate) of unsigned := - (B75 => OSC.B75, - B110 => OSC.B110, - B150 => OSC.B150, - B300 => OSC.B300, - B600 => OSC.B600, - B1200 => OSC.B1200, - B2400 => OSC.B2400, - B4800 => OSC.B4800, - B9600 => OSC.B9600, - B19200 => OSC.B19200, - B38400 => OSC.B38400, - B57600 => OSC.B57600, - B115200 => OSC.B115200); + (B75 => OSC.B75, + B110 => OSC.B110, + B150 => OSC.B150, + B300 => OSC.B300, + B600 => OSC.B600, + B1200 => OSC.B1200, + B2400 => OSC.B2400, + B4800 => OSC.B4800, + B9600 => OSC.B9600, + B19200 => OSC.B19200, + B38400 => OSC.B38400, + B57600 => OSC.B57600, + B115200 => OSC.B115200, + B230400 => OSC.B230400, + B460800 => OSC.B460800, + B500000 => OSC.B500000, + B576000 => OSC.B576000, + B921600 => OSC.B921600, + B1000000 => OSC.B1000000, + B1152000 => OSC.B1152000, + B1500000 => OSC.B1500000, + B2000000 => OSC.B2000000, + B2500000 => OSC.B2500000, + B3000000 => OSC.B3000000, + B3500000 => OSC.B3500000, + B4000000 => OSC.B4000000); C_Bits : constant array (Data_Bits) of unsigned := (CS7 => OSC.CS7, CS8 => OSC.CS8); @@ -111,20 +120,16 @@ package body GNAT.Serial_Communications is Res : int; begin - if Port.H = null then - Port.H := new Port_Data; - end if; - - Port.H.all := Port_Data (open + Port.H := Serial_Port_Descriptor (open (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); - if Port.H.all = -1 then + if Port.H = -1 then Raise_Error ("open: open failed"); end if; -- By default we are in blocking mode - Res := fcntl (int (Port.H.all), F_SETFL, 0); + Res := fcntl (int (Port.H), F_SETFL, 0); if Res = -1 then Raise_Error ("open: fcntl failed"); @@ -156,11 +161,11 @@ package body GNAT.Serial_Communications is Res : ssize_t; begin - if Port.H = null then + if Port.H = -1 then Raise_Error ("read: port not opened", 0); end if; - Res := read (Integer (Port.H.all), Buffer'Address, Len); + Res := read (Integer (Port.H), Buffer'Address, Len); if Res = -1 then Raise_Error ("read failed"); @@ -215,13 +220,13 @@ package body GNAT.Serial_Communications is -- Warnings off, since we don't always test the result begin - if Port.H = null then + if Port.H = -1 then Raise_Error ("set: port not opened", 0); end if; -- Get current port settings - Res := tcgetattr (int (Port.H.all), Current'Address); + Res := tcgetattr (int (Port.H), Current'Address); -- Change settings now @@ -256,18 +261,27 @@ package body GNAT.Serial_Communications is -- Set port settings - Res := tcflush (int (Port.H.all), TCIFLUSH); - Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); + Res := tcflush (int (Port.H), TCIFLUSH); + Res := tcsetattr (int (Port.H), TCSANOW, Current'Address); -- Block - Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); + Res := fcntl (int (Port.H), F_SETFL, (if Block then 0 else FNDELAY)); if Res = -1 then Raise_Error ("set: fcntl failed"); end if; end Set; + ------------ + -- To_Ada -- + ------------ + + procedure To_Ada (Port : out Serial_Port; Fd : Serial_Port_Descriptor) is + begin + Port.H := Fd; + end To_Ada; + ----------- -- Write -- ----------- @@ -280,11 +294,11 @@ package body GNAT.Serial_Communications is Res : ssize_t; begin - if Port.H = null then + if Port.H = -1 then Raise_Error ("write: port not opened", 0); end if; - Res := write (int (Port.H.all), Buffer'Address, Len); + Res := write (int (Port.H), Buffer'Address, Len); if Res = -1 then Raise_Error ("write failed"); @@ -298,16 +312,12 @@ package body GNAT.Serial_Communications is ----------- procedure Close (Port : in out Serial_Port) is - procedure Unchecked_Free is - new Unchecked_Deallocation (Port_Data, Port_Data_Access); - Res : int; pragma Unreferenced (Res); begin - if Port.H /= null then - Res := close (int (Port.H.all)); - Unchecked_Free (Port.H); + if Port.H /= -1 then + Res := close (int (Port.H)); end if; end Close; diff --git a/gcc/ada/libgnat/g-sercom__mingw.adb b/gcc/ada/libgnat/g-sercom__mingw.adb index 88a23ea..c13e7b3 100644 --- a/gcc/ada/libgnat/g-sercom__mingw.adb +++ b/gcc/ada/libgnat/g-sercom__mingw.adb @@ -31,13 +31,11 @@ -- This is the Windows implementation of this package -with Ada.Streams; use Ada.Streams; -with Ada.Unchecked_Deallocation; use Ada; +with Ada.Streams; use Ada.Streams, Ada; with System; use System; with System.Communication; use System.Communication; with System.CRTL; use System.CRTL; -with System.OS_Constants; with System.Win32; use System.Win32; with System.Win32.Ext; use System.Win32.Ext; @@ -49,8 +47,6 @@ package body GNAT.Serial_Communications is -- Common types - type Port_Data is new HANDLE; - C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7); C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned := (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY); @@ -69,15 +65,11 @@ package body GNAT.Serial_Communications is ----------- procedure Close (Port : in out Serial_Port) is - procedure Unchecked_Free is - new Unchecked_Deallocation (Port_Data, Port_Data_Access); - Success : BOOL; begin - if Port.H /= null then - Success := CloseHandle (HANDLE (Port.H.all)); - Unchecked_Free (Port.H); + if Port.H /= -1 then + Success := CloseHandle (HANDLE (Port.H)); if Success = Win32.FALSE then Raise_Error ("error closing the port"); @@ -114,13 +106,11 @@ package body GNAT.Serial_Communications is pragma Unreferenced (Success); begin - if Port.H = null then - Port.H := new Port_Data; - else - Success := CloseHandle (HANDLE (Port.H.all)); + if Port.H /= -1 then + Success := CloseHandle (HANDLE (Port.H)); end if; - Port.H.all := CreateFileA + Port.H := CreateFileA (lpFileName => C_Name (C_Name'First)'Address, dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, dwShareMode => 0, @@ -129,7 +119,9 @@ package body GNAT.Serial_Communications is dwFlagsAndAttributes => 0, hTemplateFile => 0); - if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then + pragma Assert (INVALID_HANDLE_VALUE = -1); + + if Port.H = Serial_Port_Descriptor (INVALID_HANDLE_VALUE) then Raise_Error ("cannot open com port"); end if; end Open; @@ -159,13 +151,13 @@ package body GNAT.Serial_Communications is Read_Last : aliased DWORD; begin - if Port.H = null then + if Port.H = -1 then Raise_Error ("read: port not opened", 0); end if; Success := ReadFile - (hFile => HANDLE (Port.H.all), + (hFile => HANDLE (Port.H), lpBuffer => Buffer (Buffer'First)'Address, nNumberOfBytesToRead => DWORD (Buffer'Length), lpNumberOfBytesRead => Read_Last'Access, @@ -200,15 +192,14 @@ package body GNAT.Serial_Communications is Com_Settings : aliased DCB; begin - if Port.H = null then + if Port.H = -1 then Raise_Error ("set: port not opened", 0); end if; - Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); + Success := GetCommState (HANDLE (Port.H), Com_Settings'Access); if Success = Win32.FALSE then - Success := CloseHandle (HANDLE (Port.H.all)); - Port.H.all := 0; + Success := CloseHandle (HANDLE (Port.H)); Raise_Error ("set: cannot get comm state"); end if; @@ -240,11 +231,10 @@ package body GNAT.Serial_Communications is Com_Settings.Parity := BYTE (C_Parity (Parity)); Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits)); - Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); + Success := SetCommState (HANDLE (Port.H), Com_Settings'Access); if Success = Win32.FALSE then - Success := CloseHandle (HANDLE (Port.H.all)); - Port.H.all := 0; + Success := CloseHandle (HANDLE (Port.H)); Raise_Error ("cannot set comm state"); end if; @@ -274,7 +264,7 @@ package body GNAT.Serial_Communications is Success := SetCommTimeouts - (hFile => HANDLE (Port.H.all), + (hFile => HANDLE (Port.H), lpCommTimeouts => Com_Time_Out'Access); if Success = Win32.FALSE then @@ -282,6 +272,15 @@ package body GNAT.Serial_Communications is end if; end Set; + ------------ + -- To_Ada -- + ------------ + + procedure To_Ada (Port : out Serial_Port; Fd : Serial_Port_Descriptor) is + begin + Port.H := Fd; + end To_Ada; + ----------- -- Write -- ----------- @@ -294,13 +293,13 @@ package body GNAT.Serial_Communications is Temp_Last : aliased DWORD; begin - if Port.H = null then + if Port.H = -1 then Raise_Error ("write: port not opened", 0); end if; Success := WriteFile - (hFile => HANDLE (Port.H.all), + (hFile => HANDLE (Port.H), lpBuffer => Buffer'Address, nNumberOfBytesToWrite => DWORD (Buffer'Length), lpNumberOfBytesWritten => Temp_Last'Access, diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index 476a213..ceb2cb0 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -73,11 +73,15 @@ package body GNAT.Sockets is IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP, IP_Protocol_For_IPv6_Level => SOSC.IPPROTO_IPV6, IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP, - IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP); + IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP, + IP_Protocol_For_ICMP_Level => SOSC.IPPROTO_ICMP, + IP_Protocol_For_IGMP_Level => SOSC.IPPROTO_IGMP, + IP_Protocol_For_RAW_Level => SOSC.IPPROTO_RAW); Modes : constant array (Mode_Type) of C.int := (Socket_Stream => SOSC.SOCK_STREAM, - Socket_Datagram => SOSC.SOCK_DGRAM); + Socket_Datagram => SOSC.SOCK_DGRAM, + Socket_Raw => SOSC.SOCK_RAW); Shutmodes : constant array (Shutmode_Type) of C.int := (Shut_Read => SOSC.SHUT_RD, @@ -1369,7 +1373,7 @@ package body GNAT.Sockets is function Get_Socket_Option (Socket : Socket_Type; - Level : Level_Type := Socket_Level; + Level : Level_Type; Name : Option_Name; Optname : Interfaces.C.int := -1) return Option_Type is @@ -2539,7 +2543,7 @@ package body GNAT.Sockets is procedure Set_Socket_Option (Socket : Socket_Type; - Level : Level_Type := Socket_Level; + Level : Level_Type; Option : Option_Type) is use type C.unsigned; @@ -2643,21 +2647,29 @@ package body GNAT.Sockets is => if Is_Windows then - -- On Windows, the timeout is a DWORD in milliseconds, and - -- the actual timeout is 500 ms + the given value (unless it - -- is 0). + -- On Windows, the timeout is a DWORD in milliseconds - U4 := C.unsigned (Option.Timeout / 0.001); + Len := U4'Size / 8; + Add := U4'Address; - if U4 > 500 then - U4 := U4 - 500; + U4 := C.unsigned (Option.Timeout / 0.001); - elsif U4 > 0 then + if Option.Timeout > 0.0 and then U4 = 0 then + -- Avoid round to zero. Zero timeout mean unlimited. U4 := 1; end if; - Len := U4'Size / 8; - Add := U4'Address; + -- Old windows versions actual timeout is 500 ms + the given + -- value (unless it is 0). + + if Minus_500ms_Windows_Timeout /= 0 then + if U4 > 500 then + U4 := U4 - 500; + + elsif U4 > 0 then + U4 := 1; + end if; + end if; else VT := To_Timeval (Option.Timeout); diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads index 3024433..acd72f1 100644 --- a/gcc/ada/libgnat/g-socket.ads +++ b/gcc/ada/libgnat/g-socket.ads @@ -475,16 +475,17 @@ package GNAT.Sockets is -- The order of the enumeration elements should not be changed unilaterally -- because the IPv6_TCP_Preferred routine rely on it. - type Mode_Type is (Socket_Stream, Socket_Datagram); + type Mode_Type is (Socket_Stream, Socket_Datagram, Socket_Raw); -- Stream sockets provide connection-oriented byte streams. Datagram - -- sockets support unreliable connectionless message based communication. + -- sockets support unreliable connectionless message-based communication. + -- Raw sockets provide raw network-protocol access. -- The order of the enumeration elements should not be changed unilaterally - -- because the IPv6_TCP_Preferred routine rely on it. + -- because the IPv6_TCP_Preferred routine relies on it. type Shutmode_Type is (Shut_Read, Shut_Write, Shut_Read_Write); -- When a process closes a socket, the policy is to retain any data queued -- until either a delivery or a timeout expiration (in this case, the data - -- are discarded). A finer control is available through shutdown. With + -- are discarded). Finer control is available through shutdown. With -- Shut_Read, no more data can be received from the socket. With_Write, no -- more data can be transmitted. Neither transmission nor reception can be -- performed with Shut_Read_Write. @@ -772,37 +773,119 @@ package GNAT.Sockets is IP_Protocol_For_IP_Level, IP_Protocol_For_IPv6_Level, IP_Protocol_For_UDP_Level, - IP_Protocol_For_TCP_Level); + IP_Protocol_For_TCP_Level, + IP_Protocol_For_ICMP_Level, + IP_Protocol_For_IGMP_Level, + IP_Protocol_For_RAW_Level); -- There are several options available to manipulate sockets. Each option - -- has a name and several values available. Most of the time, the value is - -- a boolean to enable or disable this option. + -- has a name and several values available. Most of the time, the value + -- is a boolean to enable or disable this option. Each socket option is + -- provided with an appropriate C name taken from the sockets API comments. + -- The C name can be used to find a detailed description in the OS-specific + -- documentation. The options are grouped by main Level_Type value, which + -- can be used together with this option in calls to the Set_Socket_Option + -- and Get_Socket_Option routines. Note that some options can be used with + -- more than one level. type Option_Name is (Generic_Option, - Keep_Alive, -- Enable sending of keep-alive messages - Reuse_Address, -- Allow bind to reuse local address - Broadcast, -- Enable datagram sockets to recv/send broadcasts - Send_Buffer, -- Set/get the maximum socket send buffer in bytes - Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes - Linger, -- Shutdown wait for msg to be sent or timeout occur - Error, -- Get and clear the pending socket error - No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) - Add_Membership_V4, -- Join a multicast group - Add_Membership_V6, -- Idem for IPv6 socket - Drop_Membership_V4, -- Leave a multicast group - Drop_Membership_V6, -- Idem for IPv6 socket - Multicast_If_V4, -- Set default out interface for multicast packets - Multicast_If_V6, -- Idem for IPv6 socket - Multicast_Loop_V4, -- Sent multicast packets are looped to local socket - Multicast_Loop_V6, -- Idem for IPv6 socket - Multicast_TTL, -- Set the time-to-live of sent multicast packets - Multicast_Hops, -- Set the multicast hop limit for the IPv6 socket - Receive_Packet_Info, -- Receive low level packet info as ancillary data - Send_Timeout, -- Set timeout value for output - Receive_Timeout, -- Set timeout value for input - IPv6_Only, -- Restricted to IPv6 communications only - Busy_Polling); -- Set busy polling mode + -- Can be used to set/get any socket option via an OS-specific option + -- code with an integer value. + + ------------------ + -- Socket_Level -- + ------------------ + + Keep_Alive, -- SO_KEEPALIVE + -- Enable sending of keep-alive messages on connection-oriented sockets + + Reuse_Address, -- SO_REUSEADDR + -- Enable binding to an address and port already in use + + Broadcast, -- SO_BROADCAST + -- Enable sending broadcast datagrams on the socket + + Send_Buffer, -- SO_SNDBUF + -- Set/get the maximum socket send buffer in bytes + + Receive_Buffer, -- SO_RCVBUF + -- Set/get the maximum socket receive buffer in bytes + + Linger, -- SO_LINGER + -- When enabled, a Close_Socket or Shutdown_Socket will wait until all + -- queued messages for the socket have been successfully sent or the + -- linger timeout has been reached. + + Error, -- SO_ERROR + -- Get and clear the pending socket error integer code + + Send_Timeout, -- SO_SNDTIMEO + -- Specify sending timeout until reporting an error + + Receive_Timeout, -- SO_RCVTIMEO + -- Specify receiving timeout until reporting an error + + Busy_Polling, -- SO_BUSY_POLL + -- Sets the approximate time in microseconds to busy poll on a blocking + -- receive when there is no data. + + ------------------------------- + -- IP_Protocol_For_TCP_Level -- + ------------------------------- + + No_Delay, -- TCP_NODELAY + -- Disable the Nagle algorithm. This means that output buffer content + -- is always sent as soon as possible, even if there is only a small + -- amount of data. + + ------------------------------ + -- IP_Protocol_For_IP_Level -- + ------------------------------ + + Add_Membership_V4, -- IP_ADD_MEMBERSHIP + -- Join a multicast group + + Drop_Membership_V4, -- IP_DROP_MEMBERSHIP + -- Leave a multicast group + + Multicast_If_V4, -- IP_MULTICAST_IF + -- Set/Get outgoing interface for sending multicast packets + + Multicast_Loop_V4, -- IP_MULTICAST_LOOP + -- This boolean option determines whether sent multicast packets should + -- be looped back to the local sockets. + + Multicast_TTL, -- IP_MULTICAST_TTL + -- Set/Get the time-to-live of sent multicast packets + + Receive_Packet_Info, -- IP_PKTINFO + -- Receive low-level packet info as ancillary data + + -------------------------------- + -- IP_Protocol_For_IPv6_Level -- + -------------------------------- + + Add_Membership_V6, -- IPV6_ADD_MEMBERSHIP + -- Join IPv6 multicast group + + Drop_Membership_V6, -- IPV6_DROP_MEMBERSHIP + -- Leave IPv6 multicast group + + Multicast_If_V6, -- IPV6_MULTICAST_IF + -- Set/Get outgoing interface index for sending multicast packets + + Multicast_Loop_V6, -- IPV6_MULTICAST_LOOP + -- This boolean option determines whether sent multicast IPv6 packets + -- should be looped back to the local sockets. + + IPv6_Only, -- IPV6_V6ONLY + -- Restricted to IPv6 communications only + + Multicast_Hops -- IPV6_MULTICAST_HOPS + -- Set the multicast hop limit for the IPv6 socket + ); + subtype Specific_Option_Name is Option_Name range Keep_Alive .. Option_Name'Last; @@ -1084,7 +1167,7 @@ package GNAT.Sockets is function Get_Socket_Option (Socket : Socket_Type; - Level : Level_Type := Socket_Level; + Level : Level_Type; Name : Option_Name; Optname : Interfaces.C.int := -1) return Option_Type; -- Get the options associated with a socket. Raises Socket_Error on error. @@ -1199,7 +1282,7 @@ package GNAT.Sockets is procedure Set_Socket_Option (Socket : Socket_Type; - Level : Level_Type := Socket_Level; + Level : Level_Type; Option : Option_Type); -- Manipulate socket options. Raises Socket_Error on error diff --git a/gcc/ada/libgnat/g-sothco.ads b/gcc/ada/libgnat/g-sothco.ads index dc47f92..c62161d 100644 --- a/gcc/ada/libgnat/g-sothco.ads +++ b/gcc/ada/libgnat/g-sothco.ads @@ -438,6 +438,11 @@ package GNAT.Sockets.Thin_Common is renames Short_To_Network; -- Symmetric operation + function Minus_500ms_Windows_Timeout return C.int; + -- Microsoft Windows desktop older then 8.0 and Microsoft Windows Server + -- older than 2019 need timeout correction for 500 milliseconds. This + -- routine returns 1 for such versions. + private pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); @@ -470,4 +475,6 @@ private pragma Import (C, Hostent_H_Length, "__gnat_hostent_h_length"); pragma Import (C, Hostent_H_Addr, "__gnat_hostent_h_addr"); + pragma Import (C, Minus_500ms_Windows_Timeout, "__gnat_minus_500ms"); + end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/libgnat/g-spipat.ads b/gcc/ada/libgnat/g-spipat.ads index 4d6a7f8..4dfc25a 100644 --- a/gcc/ada/libgnat/g-spipat.ads +++ b/gcc/ada/libgnat/g-spipat.ads @@ -48,7 +48,7 @@ -- matching with the restriction that it matches entire strings. It -- is particularly useful for file name matching, and in particular -- it provides "globbing patterns" that are useful in implementing --- unix or DOS style wild card matching for file names. +-- unix or DOS style wildcard matching for file names. -- GNAT.Regpat (files g-regpat.ads/g-regpat.adb) -- This is a more complete implementation of Unix-style regular diff --git a/gcc/ada/libgnat/g-traceb.adb b/gcc/ada/libgnat/g-traceb.adb index cc52e57..9cf04de 100644 --- a/gcc/ada/libgnat/g-traceb.adb +++ b/gcc/ada/libgnat/g-traceb.adb @@ -47,4 +47,16 @@ package body GNAT.Traceback is System.Traceback.Call_Chain (Traceback, Traceback'Length, Len); end Call_Chain; + function Call_Chain + (Max_Len : Positive; + Skip_Frames : Natural := 1) return Tracebacks_Array + is + Traceback : Tracebacks_Array (1 .. Max_Len); + Len : Natural; + begin + System.Traceback.Call_Chain + (Traceback, Max_Len, Len, Skip_Frames => Skip_Frames + 1); + return Traceback (1 .. Len); + end Call_Chain; + end GNAT.Traceback; diff --git a/gcc/ada/libgnat/g-traceb.ads b/gcc/ada/libgnat/g-traceb.ads index aeb3b0a..6a565c9 100644 --- a/gcc/ada/libgnat/g-traceb.ads +++ b/gcc/ada/libgnat/g-traceb.ads @@ -98,4 +98,14 @@ package GNAT.Traceback is -- shorter, in which case positions in Traceback past the Len position -- are undefined on return. + function Call_Chain + (Max_Len : Positive; + Skip_Frames : Natural := 1) return Tracebacks_Array; + -- Returns up to Max_Len tracebacks corresponding to the current call + -- chain. Result array order is the same as in above procedure Call_Chain + -- except that Skip_Frames says how many of the most recent calls should be + -- excluded from the result, starting with this procedure itself: 1 means + -- exclude the frame for this procedure, 2 means 1 + exclude the frame for + -- this procedure's caller, ... + end GNAT.Traceback; diff --git a/gcc/ada/libgnat/s-imenne.adb b/gcc/ada/libgnat/s-imenne.adb index 2ea9fc7..30df1a4 100644 --- a/gcc/ada/libgnat/s-imenne.adb +++ b/gcc/ada/libgnat/s-imenne.adb @@ -49,7 +49,8 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Natural_8; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -79,7 +80,8 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Natural_16; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -109,7 +111,8 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Natural_32; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is diff --git a/gcc/ada/libgnat/s-memory.adb b/gcc/ada/libgnat/s-memory.adb index f34a92b..ebc168e 100644 --- a/gcc/ada/libgnat/s-memory.adb +++ b/gcc/ada/libgnat/s-memory.adb @@ -33,13 +33,10 @@ -- This implementation assumes that the underlying malloc/free/realloc -- implementation is thread safe, and thus, no additional lock is required. --- Note that we still need to defer abort because on most systems, an --- asynchronous signal (as used for implementing asynchronous abort of --- task) cannot safely be handled while malloc is executing. - --- If you are not using Ada constructs containing the "abort" keyword, then --- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from --- this unit. +-- Note that when using sjlj exception handling, we still need to defer abort +-- because an asynchronous signal (as used for implementing asynchronous abort +-- of task on sjlj runtimes) cannot safely be handled while malloc is +-- executing. pragma Compiler_Unit_Warning; @@ -80,7 +77,7 @@ package body System.Memory is raise Storage_Error with "object too large"; end if; - if Parameters.No_Abort then + if ZCX_By_Default or else Parameters.No_Abort then Result := c_malloc (System.CRTL.size_t (Size)); else Abort_Defer.all; @@ -121,7 +118,7 @@ package body System.Memory is procedure Free (Ptr : System.Address) is begin - if Parameters.No_Abort then + if ZCX_By_Default or else Parameters.No_Abort then c_free (Ptr); else Abort_Defer.all; @@ -145,7 +142,7 @@ package body System.Memory is raise Storage_Error with "object too large"; end if; - if Parameters.No_Abort then + if ZCX_By_Default or else Parameters.No_Abort then Result := c_realloc (Ptr, System.CRTL.size_t (Size)); else Abort_Defer.all; diff --git a/gcc/ada/libgnat/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb index 7efddf7..c3c1979 100644 --- a/gcc/ada/libgnat/s-os_lib.adb +++ b/gcc/ada/libgnat/s-os_lib.adb @@ -1629,10 +1629,12 @@ package body System.OS_Lib is pragma Import (C, C_Kill, "__gnat_kill"); begin - if Hard_Kill then - C_Kill (Pid, SIGKILL, 1); - else - C_Kill (Pid, SIGINT, 1); + if Pid /= Invalid_Pid then + if Hard_Kill then + C_Kill (Pid, SIGKILL, 1); + else + C_Kill (Pid, SIGINT, 1); + end if; end if; end Kill; diff --git a/gcc/ada/libgnat/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads index 8b21aa7..3e8c21d 100644 --- a/gcc/ada/libgnat/s-os_lib.ads +++ b/gcc/ada/libgnat/s-os_lib.ads @@ -246,7 +246,7 @@ package System.OS_Lib is Success : out Boolean; Mode : Copy_Mode := Copy; Preserve : Attribute := Time_Stamps); - -- Copy a file. Name must designate a single file (no wild cards allowed). + -- Copy a file. Name must designate a single file (no wildcards allowed). -- Pathname can be a filename or directory name. In the latter case Name -- is copied into the directory preserving the same file name. Mode -- defines the kind of copy, see above with the default being a normal diff --git a/gcc/ada/libgnat/s-regexp.ads b/gcc/ada/libgnat/s-regexp.ads index f521f91..4d9fb5b 100644 --- a/gcc/ada/libgnat/s-regexp.ads +++ b/gcc/ada/libgnat/s-regexp.ads @@ -77,7 +77,7 @@ package System.Regexp is -- See also regexp(1) man page on Unix systems for further details -- A second kind of regular expressions is provided. This one is more - -- like the wild card patterns used in file names by the Unix shell (or + -- like the wildcard patterns used in file names by the Unix shell (or -- DOS prompt) command lines. The grammar is the following: -- regexp ::= term diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads index 20dc4e6..e050bc1 100644 --- a/gcc/ada/libgnat/s-stratt.ads +++ b/gcc/ada/libgnat/s-stratt.ads @@ -154,7 +154,7 @@ package System.Stream_Attributes is function Block_IO_OK return Boolean; -- Package System.Stream_Attributes has several bodies - the default one - -- distributed with GNAT, and s-stratt-xdr.adb, which is based on the XDR + -- distributed with GNAT, and s-stratt__xdr.adb, which is based on the XDR -- standard. Both bodies share the same spec. The role of this function is -- to indicate whether the current version of System.Stream_Attributes -- supports block IO. See System.Strings.Stream_Ops (s-ststop) for details. diff --git a/gcc/ada/libgnat/s-ststop.adb b/gcc/ada/libgnat/s-ststop.adb index 9f5c6ec..cf594b0 100644 --- a/gcc/ada/libgnat/s-ststop.adb +++ b/gcc/ada/libgnat/s-ststop.adb @@ -31,8 +31,8 @@ pragma Compiler_Unit_Warning; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Ada.Streams; use Ada.Streams; -with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Unchecked_Conversion; with System; use System; diff --git a/gcc/ada/libgnat/s-valboo.ads b/gcc/ada/libgnat/s-valboo.ads index bed1ae3..f900621 100644 --- a/gcc/ada/libgnat/s-valboo.ads +++ b/gcc/ada/libgnat/s-valboo.ads @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ package System.Val_Bool is - pragma Pure; + pragma Preelaborate; function Value_Boolean (Str : String) return Boolean; -- Computes Boolean'Value (Str) diff --git a/gcc/ada/libgnat/s-valcha.ads b/gcc/ada/libgnat/s-valcha.ads index 0d3edfc..b9d5373 100644 --- a/gcc/ada/libgnat/s-valcha.ads +++ b/gcc/ada/libgnat/s-valcha.ads @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ package System.Val_Char is - pragma Pure; + pragma Preelaborate; function Value_Character (Str : String) return Character; -- Computes Character'Value (Str) diff --git a/gcc/ada/libgnat/s-valdec.ads b/gcc/ada/libgnat/s-valdec.ads index 9d47333..ec10490 100644 --- a/gcc/ada/libgnat/s-valdec.ads +++ b/gcc/ada/libgnat/s-valdec.ads @@ -34,7 +34,7 @@ -- Decimal_IO, and the Value attribute for such decimal types. package System.Val_Dec is - pragma Pure; + pragma Preelaborate; function Scan_Decimal (Str : String; diff --git a/gcc/ada/libgnat/s-valenu.ads b/gcc/ada/libgnat/s-valenu.ads index 343acf3..e2a3a15 100644 --- a/gcc/ada/libgnat/s-valenu.ads +++ b/gcc/ada/libgnat/s-valenu.ads @@ -34,7 +34,7 @@ -- details of the format of constructed image tables. package System.Val_Enum is - pragma Pure; + pragma Preelaborate; function Value_Enumeration_8 (Names : String; diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads index b4be1e4..d9f15ed 100644 --- a/gcc/ada/libgnat/s-valint.ads +++ b/gcc/ada/libgnat/s-valint.ads @@ -33,7 +33,7 @@ -- in Text_IO.Integer_IO, and the Value attribute. package System.Val_Int is - pragma Pure; + pragma Preelaborate; function Scan_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-vallld.ads b/gcc/ada/libgnat/s-vallld.ads index 1ff561e..17db078 100644 --- a/gcc/ada/libgnat/s-vallld.ads +++ b/gcc/ada/libgnat/s-vallld.ads @@ -34,7 +34,7 @@ -- Decimal_IO, and the Value attribute for such decimal types. package System.Val_LLD is - pragma Pure; + pragma Preelaborate; function Scan_Long_Long_Decimal (Str : String; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads index 2f510ca..ee75bdc 100644 --- a/gcc/ada/libgnat/s-vallli.ads +++ b/gcc/ada/libgnat/s-vallli.ads @@ -33,7 +33,7 @@ -- values for use in Text_IO.Integer_IO, and the Value attribute. package System.Val_LLI is - pragma Pure; + pragma Preelaborate; function Scan_Long_Long_Integer (Str : String; diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads index c518492..ddb8414 100644 --- a/gcc/ada/libgnat/s-valllu.ads +++ b/gcc/ada/libgnat/s-valllu.ads @@ -35,7 +35,7 @@ with System.Unsigned_Types; package System.Val_LLU is - pragma Pure; + pragma Preelaborate; function Scan_Raw_Long_Long_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index 9039f99..99c7360 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -71,16 +71,13 @@ package body System.Val_Real is After_Point : Natural := 0; -- Set to 1 after the point - Num_Saved_Zeroes : Natural := 0; - -- This counts zeroes after the decimal point. A non-zero value means - -- that this number of previously scanned digits are zero. If the end - -- of the number is reached, these zeroes are simply discarded, which - -- ensures that trailing zeroes after the point never affect the value - -- (which might otherwise happen as a result of rounding). With this - -- processing in place, we can ensure that, for example, we get the - -- same exact result from 1.0E+49 and 1.0000000E+49. This is not - -- necessarily required in a case like this where the result is not - -- a machine number, but it is certainly a desirable behavior. + Precision_Limit : constant Long_Long_Float := + 2.0 ** (Long_Long_Float'Machine_Mantissa - 1); + -- This is an upper bound for the number of bits used to represent the + -- mantissa. Beyond that number, any digits parsed by Scanf are useless. + -- Thus, only the scale should be updated. This ensures that infinity is + -- not reached by the temporary Uval, which could lead to erroneous + -- rounding (for example: 0.4444444... or 1<n zero>E-n). procedure Scanf; -- Scans integer literal value starting at current character position. @@ -96,56 +93,50 @@ package body System.Val_Real is ----------- procedure Scanf is - Digit : Natural; - + Digit : Natural; + Uval_Tmp : Long_Long_Float; + Precision_Limit_Reached : Boolean := False; begin loop Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Save up trailing zeroes after the decimal point - - if Digit = 0 and then After_Point = 1 then - Num_Saved_Zeroes := Num_Saved_Zeroes + 1; - - -- Here for a non-zero digit - - else - -- First deal with any previously saved zeroes - - if Num_Saved_Zeroes /= 0 then - while Num_Saved_Zeroes > Maxpow loop - Uval := Uval * Powten (Maxpow); - Num_Saved_Zeroes := Num_Saved_Zeroes - Maxpow; - Scale := Scale - Maxpow; - end loop; - Uval := Uval * Powten (Num_Saved_Zeroes); - Scale := Scale - Num_Saved_Zeroes; + if not Precision_Limit_Reached then + -- Compute potential new value + Uval_Tmp := Uval * 10.0 + Long_Long_Float (Digit); - Num_Saved_Zeroes := 0; + if Uval_Tmp > Precision_Limit then + Precision_Limit_Reached := True; end if; + end if; - -- Accumulate new digit - - Uval := Uval * 10.0 + Long_Long_Float (Digit); + if Precision_Limit_Reached then + -- If beyond the precision of the mantissa then just ignore the + -- digit, to avoid rounding issues. + if After_Point = 0 then + Scale := Scale + 1; + end if; + else + Uval := Uval_Tmp; Scale := Scale - After_Point; end if; - -- Done if end of input field + -- Check next character + P := P + 1; if P > Max then + -- Done if end of input field return; - -- Check next character - elsif Str (P) not in Digs then + -- If next character is not a digit, check if this is an + -- underscore. If this is not the case, then return. if Str (P) = '_' then Scan_Underscore (Str, P, Ptr, Max, False); else return; end if; end if; + end loop; end Scanf; @@ -198,7 +189,8 @@ package body System.Val_Real is Base_Char : constant Character := Str (P); Digit : Natural; Fdigit : Long_Long_Float; - + Uval_Tmp : Long_Long_Float; + Precision_Limit_Reached : Boolean := False; begin -- Set bad base if out of range, and use safe base of 16.0, -- to guard against division by zero in the loop below. @@ -243,22 +235,24 @@ package body System.Val_Real is Bad_Value (Str); end if; - -- Save up trailing zeroes after the decimal point + if not Precision_Limit_Reached then + -- Compute potential new value + Uval_Tmp := Uval * Base + Long_Long_Float (Digit); - if Digit = 0 and then After_Point = 1 then - Num_Saved_Zeroes := Num_Saved_Zeroes + 1; + if Uval_Tmp > Precision_Limit then + Precision_Limit_Reached := True; + end if; + end if; - -- Here for a non-zero digit + if Precision_Limit_Reached then + -- If beyond precision of the mantissa then just update + -- the scale and discard remaining digits. - else - -- First deal with any previously saved zeroes - - if Num_Saved_Zeroes /= 0 then - Uval := Uval * Base ** Num_Saved_Zeroes; - Scale := Scale - Num_Saved_Zeroes; - Num_Saved_Zeroes := 0; + if After_Point = 0 then + Scale := Scale + 1; end if; + else -- Now accumulate the new digit Fdigit := Long_Long_Float (Digit); @@ -267,7 +261,7 @@ package body System.Val_Real is Bad_Base := True; else Scale := Scale - After_Point; - Uval := Uval * Base + Fdigit; + Uval := Uval_Tmp; end if; end if; diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads index 49607ed..b59f345 100644 --- a/gcc/ada/libgnat/s-valrea.ads +++ b/gcc/ada/libgnat/s-valrea.ads @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ package System.Val_Real is - pragma Pure; + pragma Preelaborate; function Scan_Real (Str : String; diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads index 741ae6f..7d261b1 100644 --- a/gcc/ada/libgnat/s-valuns.ads +++ b/gcc/ada/libgnat/s-valuns.ads @@ -35,7 +35,7 @@ with System.Unsigned_Types; package System.Val_Uns is - pragma Pure; + pragma Preelaborate; function Scan_Raw_Unsigned (Str : String; diff --git a/gcc/ada/libgnat/s-valwch.ads b/gcc/ada/libgnat/s-valwch.ads index 5a72295..5179517 100644 --- a/gcc/ada/libgnat/s-valwch.ads +++ b/gcc/ada/libgnat/s-valwch.ads @@ -34,7 +34,7 @@ with System.WCh_Con; package System.Val_WChar is - pragma Pure; + pragma Preelaborate; function Value_Wide_Character (Str : String; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 750e62f..805addb 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -502,7 +502,7 @@ package body Make is -- linker). For the sake of convenience, some program specific switches -- can be passed directly on the gnatmake command line. This procedure -- records these switches so that gnatmake can pass them to the right - -- program. S is the switch to be added at the end of the command line + -- program. S is the switch to be added at the end of the command line -- for Program if Append_Switch is True. If Append_Switch is False S is -- added at the beginning of the command line. diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c index d061476..e0efcce 100644 --- a/gcc/ada/mkdir.c +++ b/gcc/ada/mkdir.c @@ -35,8 +35,7 @@ #endif /* __vxworks */ #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" +#include "runtime.h" #include <sys/stat.h> #else #include "config.h" diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index a54735a..bdd3dad 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -431,7 +431,7 @@ package Namet is -- Uhh encoding (hh = hex code), other 16-bit wide character values are -- stored using the Whhhh (hhhh = hex code) encoding, and other 32-bit wide -- wide character values are stored using the WWhhhhhhhh (hhhhhhhh = hex - -- code). Note that this procedure does not fold upper case letters (they + -- code). Note that this procedure does not fold upper case letters (they -- are stored using the Uhh encoding). procedure Set_Character_Literal_Name diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index 43d340b..4ceffb0 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -248,7 +248,14 @@ package body Opt is SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config; else - if GNAT_Mode_Config then + -- In GNATprove mode assertions should be always enabled, even + -- when analysing internal units. + + if GNATprove_Mode then + pragma Assert (Assertions_Enabled); + null; + + elsif GNAT_Mode_Config then Assertions_Enabled := Assertions_Enabled_Config; else Assertions_Enabled := False; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 16b5cba..4d3e87e 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -947,6 +947,11 @@ package Opt is -- Set to True when the pre-18.x access-before-elaboration model is to be -- used. Modified by use of -gnatH. + Legacy_Elaboration_Order : Boolean := False; + -- GNATBIND + -- Set to True when the pre-20.x elaboration-order model is to be used. + -- Modified by use of -H. + Link_Only : Boolean := False; -- GNATMAKE, GPRBUILD -- Set to True to skip compile and bind steps (except when Bind_Only is @@ -1115,6 +1120,12 @@ package Opt is -- Maximum number of processes that should be spawned to carry out -- compilations. + Minimal_Binder : Boolean := False; + -- GNATBIND + -- Set to True to suppress the generation of objects by the binder that + -- are not strictly required for a program to run. Intended for ZFP + -- applications that have tight memory constraints. + Minimal_Recompilation : Boolean := False; -- GNATMAKE -- Set to True if minimal recompilation mode requested @@ -1979,7 +1990,7 @@ package Opt is -- set by the command line switches -gnat83/95/2005/2012, and possibly -- modified by the use of configuration pragmas Ada_*. This switch is used -- to set the initial value for Ada_Version mode at the start of analysis - -- of a unit. Note however that the setting of this flag is ignored for + -- of a unit. Note however that the setting of this flag is ignored for -- internal and predefined units (which are always compiled in the most up -- to date version of Ada). diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb index 8af5aa0..9fb9ee3 100644 --- a/gcc/ada/osint-c.adb +++ b/gcc/ada/osint-c.adb @@ -385,6 +385,21 @@ package body Osint.C is end if; end loop; + -- If we are in multiple-units-per-file mode, then add a ~nnn extension + -- to the name. + + if Multiple_Unit_Index /= 0 then + declare + Exten : constant String := Name_Buffer (Dot_Index .. Name_Len); + begin + Name_Len := Dot_Index - 1; + Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); + Add_Nat_To_Name_Buffer (Multiple_Unit_Index); + Dot_Index := Name_Len + 1; + Add_Str_To_Name_Buffer (Exten); + end; + end if; + -- Make sure that the output file name matches the source file name. -- To compare them, remove file name directories and extensions. @@ -395,21 +410,6 @@ package body Osint.C is Name_Buffer (Dot_Index) := '.'; - -- If we are in multiple unit per file mode, then add ~nnn - -- extension to the name before doing the comparison. - - if Multiple_Unit_Index /= 0 then - declare - Exten : constant String := Name_Buffer (Dot_Index .. Name_Len); - begin - Name_Len := Dot_Index - 1; - Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); - Add_Nat_To_Name_Buffer (Multiple_Unit_Index); - Dot_Index := Name_Len + 1; - Add_Str_To_Name_Buffer (Exten); - end; - end if; - -- Remove extension preparing to replace it declare diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 9de9a60..b9b0214 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -2262,7 +2262,7 @@ package body Ch4 is -- capacity-exceeded error. The purpose of this trick is to avoid -- creating a deeply nested tree, which would cause deep recursion -- during semantics, causing stack overflow. This way, we can handle - -- enormous concatenations in the normal case of predefined "&". We + -- enormous concatenations in the normal case of predefined "&". We -- first build up the normal tree, and then rewrite it if -- appropriate. diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 0c4672c..0fc7109 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1442,7 +1442,7 @@ package body Ch6 is Look_Ahead : loop -- If we run into a semicolon, then assume that a - -- colon was missing, e.g. Parms (X Y; ...). Also + -- colon was missing, e.g. Parms (X Y; ...). Also -- assume missing colon on EOF (a real disaster) -- and on a right paren, e.g. Parms (X Y), and also -- on an assignment symbol, e.g. Parms (X Y := ..) diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb index 1edc803..899905e 100644 --- a/gcc/ada/par-labl.adb +++ b/gcc/ada/par-labl.adb @@ -79,7 +79,7 @@ procedure Labl is -- then we have an error. -- Note that in the worst case, this is quadratic in the number - -- of labels. However, labels are not all that common, and this + -- of labels. However, labels are not all that common, and this -- is only called for explicit labels. -- ???Nonetheless, the efficiency could be improved. For example, diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb index cb95500..70bc5cb 100644 --- a/gcc/ada/par-load.adb +++ b/gcc/ada/par-load.adb @@ -36,7 +36,6 @@ with Uname; use Uname; with Osint; use Osint; with Sinput.L; use Sinput.L; with Stylesw; use Stylesw; -with Validsw; use Validsw; with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; @@ -61,10 +60,6 @@ procedure Load is Save_Style_Checks : Style_Check_Options; -- Save style check so it can be restored later - Save_Validity_Check : Boolean; - Save_Validity_Checks : Validity_Check_Options; - -- Save validity check so it can be restored later - With_Cunit : Node_Id; -- Compilation unit node for withed unit @@ -134,9 +129,6 @@ begin Save_Style_Check_Options (Save_Style_Checks); Save_Style_Check := Opt.Style_Check; - Save_Validity_Check_Options (Save_Validity_Checks); - Save_Validity_Check := Opt.Validity_Checks_On; - -- If main unit, set Main_Unit_Entity (this will get overwritten if -- the main unit has a separate spec, that happens later on in Load) @@ -318,11 +310,10 @@ begin or else Nkind (Unit (Curunit)) in N_Generic_Instantiation or else Nkind (Unit (Curunit)) in N_Renaming_Declaration then - -- Turn style and validity checks off for parent unit + -- Turn style checks off for parent unit if not GNAT_Mode then Reset_Style_Check_Options; - Reset_Validity_Check_Options; end if; Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum)); @@ -356,11 +347,10 @@ begin end if; end if; - -- Now we load with'ed units, with style/validity checks turned off + -- Now we load with'ed units, with style checks turned off if not GNAT_Mode then Reset_Style_Check_Options; - Reset_Validity_Check_Options; end if; -- Load the context items in two rounds: the first round handles normal @@ -470,6 +460,4 @@ begin Set_Style_Check_Options (Save_Style_Checks); Opt.Style_Check := Save_Style_Check; - Set_Validity_Check_Options (Save_Validity_Checks); - Opt.Validity_Checks_On := Save_Validity_Check; end Load; diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index 42ff57b..8549f79 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -825,7 +825,7 @@ package body Prep is ------------------ procedure List_Symbols (Foreword : String) is - Order : array (0 .. Integer (Symbol_Table.Last (Mapping))) + Order : array (0 .. Integer (Symbol_Table.Last (Mapping))) of Symbol_Id; -- After alphabetical sorting, this array stores the indexes of the -- symbols in the order they are displayed. diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 6092a87..c15547d 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -39,11 +39,11 @@ /* Don't use fancy_abort. */ # undef abort #else -# ifndef CERT +# if !defined(CERT) && !defined(STANDALONE) # include "tconfig.h" # include "tsystem.h" # else -# define ATTRIBUTE_UNUSED __attribute__((unused)) +# include "runtime.h" # define HAVE_GETIPINFO 1 # endif #endif @@ -115,6 +115,10 @@ extern void __gnat_unhandled_except_handler (_Unwind_Exception *); /* Called in case of error during propagation. */ extern void __gnat_raise_abort (void) __attribute__ ((noreturn)); #define abort() __gnat_raise_abort() + +#elif defined(STANDALONE) +#include <stdlib.h> +#define inhibit_libc #endif #include "unwind-pe.h" diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c index 480a0ea..bf8a879 100644 --- a/gcc/ada/raise.c +++ b/gcc/ada/raise.c @@ -33,8 +33,7 @@ is shared between all exception handling mechanisms. */ #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" +#include "runtime.h" #else #include "config.h" #include "system.h" @@ -56,16 +55,6 @@ extern "C" { void __gnat_unhandled_terminate (void) { -#ifdef VMS - /* Special termination handling for VMS */ - long prvhnd; - - /* Remove the exception vector so it won't intercept any errors - in the call to exit, and go into and endless loop */ - - SYS$SETEXV (1, 0, 3, &prvhnd); -#endif - /* Default termination handling */ __gnat_os_exit (1); } diff --git a/gcc/ada/repinfo-input.adb b/gcc/ada/repinfo-input.adb new file mode 100644 index 0000000..92ca510 --- /dev/null +++ b/gcc/ada/repinfo-input.adb @@ -0,0 +1,1350 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E P I N F O - I N P U T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2018-2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Alloc; +with Csets; use Csets; +with Hostparm; use Hostparm; +with Namet; use Namet; +with Output; use Output; +with Snames; use Snames; +with Table; + +package body Repinfo.Input is + + SSU : constant := 8; + -- Value for Storage_Unit, we do not want to get this from TTypes, since + -- this introduces problematic dependencies in ASIS, and in any case this + -- value is assumed to be 8 for the implementation of the DDA. + + type JSON_Entity_Kind is (JE_Record_Type, JE_Array_Type, JE_Other); + -- Kind of an entiy + + type JSON_Entity_Node (Kind : JSON_Entity_Kind := JE_Other) is record + Esize : Node_Ref_Or_Val; + RM_Size : Node_Ref_Or_Val; + case Kind is + when JE_Record_Type => Variant : Nat; + when JE_Array_Type => Component_Size : Node_Ref_Or_Val; + when JE_Other => Dummy : Boolean; + end case; + end record; + pragma Unchecked_Union (JSON_Entity_Node); + -- Record to represent an entity + + package JSON_Entity_Table is new Table.Table ( + Table_Component_Type => JSON_Entity_Node, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Rep_JSON_Table_Initial, + Table_Increment => Alloc.Rep_JSON_Table_Increment, + Table_Name => "JSON_Entity_Table"); + -- Table of entities + + type JSON_Component_Node is record + Bit_Offset : Node_Ref_Or_Val; + Esize : Node_Ref_Or_Val; + end record; + -- Record to represent a component + + package JSON_Component_Table is new Table.Table ( + Table_Component_Type => JSON_Component_Node, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Rep_JSON_Table_Initial, + Table_Increment => Alloc.Rep_JSON_Table_Increment, + Table_Name => "JSON_Component_Table"); + -- Table of components + + type JSON_Variant_Node is record + Present : Node_Ref_Or_Val; + Variant : Nat; + Next : Nat; + end record; + -- Record to represent a variant + + package JSON_Variant_Table is new Table.Table ( + Table_Component_Type => JSON_Variant_Node, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => Alloc.Rep_JSON_Table_Initial, + Table_Increment => Alloc.Rep_JSON_Table_Increment, + Table_Name => "JSON_Variant_Table"); + -- Table of variants + + ------------------------------------- + -- Get_JSON_Component_Bit_Offset -- + ------------------------------------- + + function Get_JSON_Component_Bit_Offset + (Name : String; + Record_Name : String) return Node_Ref_Or_Val + is + Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name); + Index : constant Int := Get_Name_Table_Int (Namid); + + begin + -- Return No_Uint if no information is available for the component + + if Index = 0 then + return No_Uint; + end if; + + return JSON_Component_Table.Table (Index).Bit_Offset; + end Get_JSON_Component_Bit_Offset; + + ------------------------------- + -- Get_JSON_Component_Size -- + ------------------------------- + + function Get_JSON_Component_Size (Name : String) return Node_Ref_Or_Val is + Namid : constant Valid_Name_Id := Name_Find (Name); + Index : constant Int := Get_Name_Table_Int (Namid); + + begin + -- Return No_Uint if no information is available for the component + + if Index = 0 then + return No_Uint; + end if; + + return JSON_Entity_Table.Table (Index).Component_Size; + end Get_JSON_Component_Size; + + ---------------------- + -- Get_JSON_Esize -- + ---------------------- + + function Get_JSON_Esize (Name : String) return Node_Ref_Or_Val is + Namid : constant Valid_Name_Id := Name_Find (Name); + Index : constant Int := Get_Name_Table_Int (Namid); + + begin + -- Return No_Uint if no information is available for the entity + + if Index = 0 then + return No_Uint; + end if; + + return JSON_Entity_Table.Table (Index).Esize; + end Get_JSON_Esize; + + ---------------------- + -- Get_JSON_Esize -- + ---------------------- + + function Get_JSON_Esize + (Name : String; + Record_Name : String) return Node_Ref_Or_Val + is + Namid : constant Valid_Name_Id := Name_Find (Record_Name & '.' & Name); + Index : constant Int := Get_Name_Table_Int (Namid); + + begin + -- Return No_Uint if no information is available for the entity + + if Index = 0 then + return No_Uint; + end if; + + return JSON_Component_Table.Table (Index).Esize; + end Get_JSON_Esize; + + ------------------------ + -- Get_JSON_RM_Size -- + ------------------------ + + function Get_JSON_RM_Size (Name : String) return Node_Ref_Or_Val is + Namid : constant Valid_Name_Id := Name_Find (Name); + Index : constant Int := Get_Name_Table_Int (Namid); + + begin + -- Return No_Uint if no information is available for the entity + + if Index = 0 then + return No_Uint; + end if; + + return JSON_Entity_Table.Table (Index).RM_Size; + end Get_JSON_RM_Size; + + ----------------------- + -- Read_JSON_Stream -- + ----------------------- + + procedure Read_JSON_Stream (Text : Text_Buffer; File_Name : String) is + + type Text_Position is record + Index : Text_Ptr := 0; + Line : Natural := 0; + Column : Natural := 0; + end record; + -- Record to represent position in the text + + type Token_Kind is + (J_NULL, + J_TRUE, + J_FALSE, + J_NUMBER, + J_INTEGER, + J_STRING, + J_ARRAY, + J_OBJECT, + J_ARRAY_END, + J_OBJECT_END, + J_COMMA, + J_COLON, + J_EOF); + -- JSON Token kind. Note that in ECMA 404 there is no notion of integer. + -- Only numbers are supported. In our implementation we return J_INTEGER + -- if there is no decimal part in the number. The semantic is that this + -- is a J_NUMBER token that might be represented as an integer. Special + -- token J_EOF means that end of stream has been reached. + + function Decode_Integer (Lo, Hi : Text_Ptr) return Uint; + -- Decode and return the integer in Text (Lo .. Hi) + + function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id; + -- Decode and return the name in Text (Lo .. Hi) + + function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode; + -- Decode and return the expression symbol in Text (Lo .. Hi) + + procedure Error (Msg : String); + pragma No_Return (Error); + -- Print an error message and raise an exception + + procedure Read_Entity; + -- Read an entity + + function Read_Name return Valid_Name_Id; + -- Read a name + + function Read_Name_With_Prefix return Valid_Name_Id; + -- Read a name and prepend a prefix + + function Read_Number return Uint; + -- Read a number + + function Read_Numerical_Expr return Node_Ref_Or_Val; + -- Read a numerical expression + + procedure Read_Record; + -- Read a record + + function Read_String return Valid_Name_Id; + -- Read a string + + procedure Read_Token + (Kind : out Token_Kind; + Token_Start : out Text_Position; + Token_End : out Text_Position); + -- Read a token and return it (this is a standard JSON lexer) + + procedure Read_Token_And_Error + (TK : Token_Kind; + Token_Start : out Text_Position; + Token_End : out Text_Position); + pragma Inline (Read_Token_And_Error); + -- Read a specified token and error out on failure + + function Read_Variant_Part return Nat; + -- Read a variant part + + procedure Skip_Value; + -- Skip a value + + Pos : Text_Position := (Text'First, 1, 1); + -- The current position in the text buffer + + Name_Buffer : Bounded_String (4 * Max_Name_Length); + -- The buffer used to build full qualifed names + + Prefix_Len : Natural := 0; + -- The length of the prefix present in Name_Buffer + + ---------------------- + -- Decode_Integer -- + ---------------------- + + function Decode_Integer (Lo, Hi : Text_Ptr) return Uint is + Len : constant Nat := Int (Hi) - Int (Lo) + 1; + + begin + -- Decode up to 9 characters manually, otherwise call into Uint + + if Len < 10 then + declare + Val : Int := 0; + + begin + for J in Lo .. Hi loop + Val := Val * 10 + + Character'Pos (Text (J)) - Character'Pos ('0'); + end loop; + return UI_From_Int (Val); + end; + + else + declare + Val : Uint := Uint_0; + + begin + for J in Lo .. Hi loop + Val := Val * 10 + + Character'Pos (Text (J)) - Character'Pos ('0'); + end loop; + return Val; + end; + end if; + end Decode_Integer; + + ------------------- + -- Decode_Name -- + ------------------- + + function Decode_Name (Lo, Hi : Text_Ptr) return Valid_Name_Id is + begin + -- Names are stored in lower case so fold them if need be + + if Is_Upper_Case_Letter (Text (Lo)) then + declare + S : String (Integer (Lo) .. Integer (Hi)); + + begin + for J in Lo .. Hi loop + S (Integer (J)) := Fold_Lower (Text (J)); + end loop; + + return Name_Find (S); + end; + + else + declare + S : String (Integer (Lo) .. Integer (Hi)); + for S'Address use Text (Lo)'Address; + + begin + return Name_Find (S); + end; + end if; + end Decode_Name; + + --------------------- + -- Decode_Symbol -- + --------------------- + + function Decode_Symbol (Lo, Hi : Text_Ptr) return TCode is + + function Cmp12 (A, B : Character) return Boolean; + pragma Inline (Cmp12); + -- Compare Text (Lo + 1 .. Lo + 2) with A & B. + + ------------- + -- Cmp12 -- + ------------- + + function Cmp12 (A, B : Character) return Boolean is + begin + return Text (Lo + 1) = A and then Text (Lo + 2) = B; + end Cmp12; + + Len : constant Nat := Int (Hi) - Int (Lo) + 1; + + -- Start of processing for Decode_Symbol + + begin + case Len is + when 1 => + case Text (Lo) is + when '+' => + return Plus_Expr; + when '-' => + return Minus_Expr; -- or Negate_Expr + when '*' => + return Mult_Expr; + when '<' => + return Lt_Expr; + when '>' => + return Gt_Expr; + when '&' => + return Bit_And_Expr; + when '#' => + return Discrim_Val; + when others => + null; + end case; + when 2 => + if Text (Lo) = '/' then + case Text (Lo + 1) is + when 't' => + return Trunc_Div_Expr; + when 'c' => + return Ceil_Div_Expr; + when 'f' => + return Floor_Div_Expr; + when 'e' => + return Exact_Div_Expr; + when others => + null; + end case; + elsif Text (Lo + 1) = '=' then + case Text (Lo) is + when '<' => + return Le_Expr; + when '>' => + return Ge_Expr; + when '=' => + return Eq_Expr; + when '!' => + return Ne_Expr; + when others => + null; + end case; + elsif Text (Lo) = 'o' and then Text (Lo + 1) = 'r' then + return Truth_Or_Expr; + end if; + when 3 => + case Text (Lo) is + when '?' => + if Cmp12 ('<', '>') then + return Cond_Expr; + end if; + when 'a' => + if Cmp12 ('b', 's') then + return Abs_Expr; + elsif Cmp12 ('n', 'd') then + return Truth_And_Expr; + end if; + when 'm' => + if Cmp12 ('a', 'x') then + return Max_Expr; + elsif Cmp12 ('i', 'n') then + return Min_Expr; + end if; + when 'n' => + if Cmp12 ('o', 't') then + return Truth_Not_Expr; + end if; + when 'x' => + if Cmp12 ('o', 'r') then + return Truth_Xor_Expr; + end if; + when 'v' => + if Cmp12 ('a', 'r') then + return Dynamic_Val; + end if; + when others => + null; + end case; + when 4 => + if Text (Lo) = 'm' + and then Text (Lo + 1) = 'o' + and then Text (Lo + 2) = 'd' + then + case Text (Lo + 3) is + when 't' => + return Trunc_Mod_Expr; + when 'c' => + return Ceil_Mod_Expr; + when 'f' => + return Floor_Mod_Expr; + when others => + null; + end case; + end if; + + pragma Annotate + (CodePeer, Intentional, + "condition predetermined", "Error called as defensive code"); + + when others => + null; + end case; + + Error ("unknown symbol"); + end Decode_Symbol; + + ----------- + -- Error -- + ----------- + + procedure Error (Msg : String) is + L : constant String := Pos.Line'Img; + C : constant String := Pos.Column'Img; + + begin + Set_Standard_Error; + Write_Eol; + Write_Str (File_Name); + Write_Char (':'); + Write_Str (L (L'First + 1 .. L'Last)); + Write_Char (':'); + Write_Str (C (C'First + 1 .. C'Last)); + Write_Char (':'); + Write_Line (Msg); + raise Invalid_JSON_Stream; + end Error; + + ------------------ + -- Read_Entity -- + ------------------ + + procedure Read_Entity is + Ent : JSON_Entity_Node; + Nam : Name_Id := No_Name; + Siz : Node_Ref_Or_Val; + Token_Start : Text_Position; + Token_End : Text_Position; + TK : Token_Kind; + + begin + Ent.Esize := No_Uint; + Ent.RM_Size := No_Uint; + Ent.Component_Size := No_Uint; + + -- Read the members as string : value pairs + + loop + case Read_String is + when Name_Name => + Nam := Read_Name; + when Name_Record => + if Nam = No_Name then + Error ("name expected"); + end if; + Ent.Variant := 0; + Prefix_Len := Natural (Length_Of_Name (Nam)); + Name_Buffer.Chars (1 .. Prefix_Len) := Get_Name_String (Nam); + Read_Record; + when Name_Variant => + Ent.Variant := Read_Variant_Part; + when Name_Size => + Siz := Read_Numerical_Expr; + Ent.Esize := Siz; + Ent.RM_Size := Siz; + when Name_Object_Size => + Ent.Esize := Read_Numerical_Expr; + when Name_Value_Size => + Ent.RM_Size := Read_Numerical_Expr; + when Name_Component_Size => + Ent.Component_Size := Read_Numerical_Expr; + when others => + Skip_Value; + end case; + + Read_Token (TK, Token_Start, Token_End); + if TK = J_OBJECT_END then + exit; + elsif TK /= J_COMMA then + Error ("comma expected"); + end if; + end loop; + + -- Store the entity into the table + + JSON_Entity_Table.Append (Ent); + + -- Associate the name with the entity + + if Nam = No_Name then + Error ("name expected"); + end if; + + Set_Name_Table_Int (Nam, JSON_Entity_Table.Last); + end Read_Entity; + + ----------------- + -- Read_Name -- + ----------------- + + function Read_Name return Valid_Name_Id is + Token_Start : Text_Position; + Token_End : Text_Position; + + begin + -- Read a single string + + Read_Token_And_Error (J_STRING, Token_Start, Token_End); + + return Decode_Name (Token_Start.Index + 1, Token_End.Index - 1); + end Read_Name; + + ----------------------------- + -- Read_Name_With_Prefix -- + ----------------------------- + + function Read_Name_With_Prefix return Valid_Name_Id is + Len : Natural; + Lo, Hi : Text_Ptr; + Token_Start : Text_Position; + Token_End : Text_Position; + + begin + -- Read a single string + + Read_Token_And_Error (J_STRING, Token_Start, Token_End); + Lo := Token_Start.Index + 1; + Hi := Token_End.Index - 1; + + -- Prepare for the concatenation with the prefix + + Len := Integer (Hi) - Integer (Lo) + 1; + if Prefix_Len + 1 + Len > Name_Buffer.Max_Length then + Error ("Name buffer too small"); + end if; + + Name_Buffer.Length := Prefix_Len + 1 + Len; + Name_Buffer.Chars (Prefix_Len + 1) := '.'; + + -- Names are stored in lower case so fold them if need be + + if Is_Upper_Case_Letter (Text (Lo)) then + for J in Lo .. Hi loop + Name_Buffer.Chars (Prefix_Len + 2 + Integer (J - Lo)) := + Fold_Lower (Text (J)); + end loop; + + else + declare + S : String (Integer (Lo) .. Integer (Hi)); + for S'Address use Text (Lo)'Address; + + begin + Name_Buffer.Chars (Prefix_Len + 2 .. Prefix_Len + 1 + Len) := S; + end; + end if; + + return Name_Find (Name_Buffer); + end Read_Name_With_Prefix; + + ------------------ + -- Read_Number -- + ------------------ + + function Read_Number return Uint is + Token_Start : Text_Position; + Token_End : Text_Position; + + begin + -- Only integers are to be expected here + + Read_Token_And_Error (J_INTEGER, Token_Start, Token_End); + + return Decode_Integer (Token_Start.Index, Token_End.Index); + end Read_Number; + + -------------------------- + -- Read_Numerical_Expr -- + -------------------------- + + function Read_Numerical_Expr return Node_Ref_Or_Val is + Code : TCode; + Nop : Integer; + Ops : array (1 .. 3) of Node_Ref_Or_Val; + TK : Token_Kind; + Token_Start : Text_Position; + Token_End : Text_Position; + + begin + -- Read either an integer or an expression + + Read_Token (TK, Token_Start, Token_End); + if TK = J_INTEGER then + return Decode_Integer (Token_Start.Index, Token_End.Index); + + elsif TK = J_OBJECT then + -- Read the code of the expression and decode it + + if Read_String /= Name_Code then + Error ("name expected"); + end if; + + Read_Token_And_Error (J_STRING, Token_Start, Token_End); + Code := Decode_Symbol (Token_Start.Index + 1, Token_End.Index - 1); + Read_Token_And_Error (J_COMMA, Token_Start, Token_End); + + -- Read the array of operands + + if Read_String /= Name_Operands then + Error ("operands expected"); + end if; + + Read_Token_And_Error (J_ARRAY, Token_Start, Token_End); + + Nop := 0; + Ops := (others => No_Uint); + loop + Nop := Nop + 1; + Ops (Nop) := Read_Numerical_Expr; + Read_Token (TK, Token_Start, Token_End); + if TK = J_ARRAY_END then + exit; + elsif TK /= J_COMMA then + Error ("comma expected"); + end if; + end loop; + + Read_Token_And_Error (J_OBJECT_END, Token_Start, Token_End); + + -- Resolve the ambiguity for '-' now + + if Code = Minus_Expr and then Nop = 1 then + Code := Negate_Expr; + end if; + + return Create_Node (Code, Ops (1), Ops (2), Ops (3)); + + else + Error ("numerical expression expected"); + end if; + end Read_Numerical_Expr; + + ------------------- + -- Read_Record -- + ------------------- + + procedure Read_Record is + Comp : JSON_Component_Node; + First_Bit : Node_Ref_Or_Val := No_Uint; + Is_First : Boolean := True; + Nam : Name_Id := No_Name; + Position : Node_Ref_Or_Val := No_Uint; + TK : Token_Kind; + Token_Start : Text_Position; + Token_End : Text_Position; + + begin + -- Read a possibly empty array of components + + Read_Token_And_Error (J_ARRAY, Token_Start, Token_End); + + loop + Read_Token (TK, Token_Start, Token_End); + if Is_First and then TK = J_ARRAY_END then + exit; + elsif TK /= J_OBJECT then + Error ("object expected"); + end if; + + -- Read the members as string : value pairs + + loop + case Read_String is + when Name_Name => + Nam := Read_Name_With_Prefix; + when Name_Discriminant => + Skip_Value; + when Name_Position => + Position := Read_Numerical_Expr; + when Name_First_Bit => + First_Bit := Read_Number; + when Name_Size => + Comp.Esize := Read_Numerical_Expr; + when others => + Error ("invalid component"); + end case; + + Read_Token (TK, Token_Start, Token_End); + if TK = J_OBJECT_END then + exit; + elsif TK /= J_COMMA then + Error ("comma expected"); + end if; + end loop; + + -- Compute Component_Bit_Offset from Position and First_Bit, + -- either symbolically or literally depending on Position. + + if Position = No_Uint or else First_Bit = No_Uint then + Error ("bit offset expected"); + end if; + + if Position < Uint_0 then + declare + Bit_Position : constant Node_Ref_Or_Val := + Create_Node (Mult_Expr, Position, UI_From_Int (SSU)); + begin + if First_Bit = Uint_0 then + Comp.Bit_Offset := Bit_Position; + else + Comp.Bit_Offset := + Create_Node (Plus_Expr, Bit_Position, First_Bit); + end if; + end; + else + Comp.Bit_Offset := Position * SSU + First_Bit; + end if; + + -- Store the component into the table + + JSON_Component_Table.Append (Comp); + + -- Associate the name with the component + + if Nam = No_Name then + Error ("name expected"); + end if; + + Set_Name_Table_Int (Nam, JSON_Component_Table.Last); + + Read_Token (TK, Token_Start, Token_End); + if TK = J_ARRAY_END then + exit; + elsif TK /= J_COMMA then + Error ("comma expected"); + end if; + + Is_First := False; + end loop; + end Read_Record; + + ------------------ + -- Read_String -- + ------------------ + + function Read_String return Valid_Name_Id is + Token_Start : Text_Position; + Token_End : Text_Position; + Nam : Valid_Name_Id; + + begin + -- Read the string and the following colon + + Read_Token_And_Error (J_STRING, Token_Start, Token_End); + Nam := Decode_Name (Token_Start.Index + 1, Token_End.Index - 1); + Read_Token_And_Error (J_COLON, Token_Start, Token_End); + + return Nam; + end Read_String; + + ------------------ + -- Read_Token -- + ------------------ + + procedure Read_Token + (Kind : out Token_Kind; + Token_Start : out Text_Position; + Token_End : out Text_Position) + is + procedure Next_Char; + -- Update Pos to point to next char + + function Is_Whitespace return Boolean; + pragma Inline (Is_Whitespace); + -- Return True of current character is a whitespace + + function Is_Structural_Token return Boolean; + pragma Inline (Is_Structural_Token); + -- Return True if current character is one of the structural tokens + + function Is_Token_Sep return Boolean; + pragma Inline (Is_Token_Sep); + -- Return True if current character is a token separator + + procedure Delimit_Keyword (Kw : String); + -- Helper function to parse tokens such as null, false and true + + --------------- + -- Next_Char -- + --------------- + + procedure Next_Char is + begin + if Pos.Index > Text'Last then + Pos.Column := Pos.Column + 1; + elsif Text (Pos.Index) = ASCII.LF then + Pos.Column := 1; + Pos.Line := Pos.Line + 1; + else + Pos.Column := Pos.Column + 1; + end if; + Pos.Index := Pos.Index + 1; + end Next_Char; + + ------------------- + -- Is_Whitespace -- + ------------------- + + function Is_Whitespace return Boolean is + begin + return + Pos.Index <= Text'Last + and then + (Text (Pos.Index) = ASCII.LF + or else + Text (Pos.Index) = ASCII.CR + or else + Text (Pos.Index) = ASCII.HT + or else + Text (Pos.Index) = ' '); + end Is_Whitespace; + + ------------------------- + -- Is_Structural_Token -- + ------------------------- + + function Is_Structural_Token return Boolean is + begin + return + Pos.Index <= Text'Last + and then + (Text (Pos.Index) = '[' + or else + Text (Pos.Index) = ']' + or else + Text (Pos.Index) = '{' + or else + Text (Pos.Index) = '}' + or else + Text (Pos.Index) = ',' + or else + Text (Pos.Index) = ':'); + end Is_Structural_Token; + + ------------------ + -- Is_Token_Sep -- + ------------------ + + function Is_Token_Sep return Boolean is + begin + return + Pos.Index > Text'Last + or else + Is_Whitespace + or else + Is_Structural_Token; + end Is_Token_Sep; + + --------------------- + -- Delimit_Keyword -- + --------------------- + + procedure Delimit_Keyword (Kw : String) is + pragma Unreferenced (Kw); + begin + while not Is_Token_Sep loop + Token_End := Pos; + Next_Char; + end loop; + end Delimit_Keyword; + + CC : Character; + Can_Be_Integer : Boolean := True; + + -- Start of processing for Read_Token + + begin + -- Skip leading whitespaces + + while Is_Whitespace loop + Next_Char; + end loop; + + -- Initialize token delimiters + + Token_Start := Pos; + Token_End := Pos; + + -- End of stream reached + + if Pos.Index > Text'Last then + Kind := J_EOF; + return; + end if; + + CC := Text (Pos.Index); + + if CC = '[' then + Next_Char; + Kind := J_ARRAY; + return; + elsif CC = ']' then + Next_Char; + Kind := J_ARRAY_END; + return; + elsif CC = '{' then + Next_Char; + Kind := J_OBJECT; + return; + elsif CC = '}' then + Next_Char; + Kind := J_OBJECT_END; + return; + elsif CC = ',' then + Next_Char; + Kind := J_COMMA; + return; + elsif CC = ':' then + Next_Char; + Kind := J_COLON; + return; + elsif CC = 'n' then + Delimit_Keyword ("null"); + Kind := J_NULL; + return; + elsif CC = 'f' then + Delimit_Keyword ("false"); + Kind := J_FALSE; + return; + elsif CC = 't' then + Delimit_Keyword ("true"); + Kind := J_TRUE; + return; + elsif CC = '"' then + -- We expect a string + -- Just scan till the end the of the string but do not attempt + -- to decode it. This means that even if we get a string token + -- it might not be a valid string from the ECMA 404 point of + -- view. + + Next_Char; + while Pos.Index <= Text'Last and then Text (Pos.Index) /= '"' loop + if Text (Pos.Index) in ASCII.NUL .. ASCII.US then + Error ("control character not allowed in string"); + end if; + + if Text (Pos.Index) = '\' then + Next_Char; + if Pos.Index > Text'Last then + Error ("non terminated string token"); + end if; + + case Text (Pos.Index) is + when 'u' => + for Idx in 1 .. 4 loop + Next_Char; + if Pos.Index > Text'Last + or else (Text (Pos.Index) not in 'a' .. 'f' + and then + Text (Pos.Index) not in 'A' .. 'F' + and then + Text (Pos.Index) not in '0' .. '9') + then + Error ("invalid unicode escape sequence"); + end if; + end loop; + when '\' | '/' | '"' | 'b' | 'f' | 'n' | 'r' | 't' => + null; + when others => + Error ("invalid escape sequence"); + end case; + end if; + Next_Char; + end loop; + + -- No quote found report and error + + if Pos.Index > Text'Last then + Error ("non terminated string token"); + end if; + + Token_End := Pos; + + -- Go to next char and ensure that this is separator. Indeed + -- construction such as "string1""string2" are not allowed + + Next_Char; + if not Is_Token_Sep then + Error ("invalid syntax"); + end if; + Kind := J_STRING; + return; + elsif CC = '-' or else CC in '0' .. '9' then + -- We expect a number + if CC = '-' then + Next_Char; + end if; + + if Pos.Index > Text'Last then + Error ("invalid number"); + end if; + + -- Parse integer part of a number. Superfluous leading zeros are + -- not allowed. + + if Text (Pos.Index) = '0' then + Token_End := Pos; + Next_Char; + elsif Text (Pos.Index) in '1' .. '9' then + Token_End := Pos; + Next_Char; + while Pos.Index <= Text'Last + and then Text (Pos.Index) in '0' .. '9' + loop + Token_End := Pos; + Next_Char; + end loop; + else + Error ("invalid number"); + end if; + + if Is_Token_Sep then + -- Valid integer number + + Kind := J_INTEGER; + return; + elsif Text (Pos.Index) /= '.' + and then Text (Pos.Index) /= 'e' + and then Text (Pos.Index) /= 'E' + then + Error ("invalid number"); + end if; + + -- Check for a fractional part + + if Text (Pos.Index) = '.' then + Can_Be_Integer := False; + Token_End := Pos; + Next_Char; + if Pos.Index > Text'Last + or else Text (Pos.Index) not in '0' .. '9' + then + Error ("invalid number"); + end if; + + while Pos.Index <= Text'Last + and then Text (Pos.Index) in '0' .. '9' + loop + Token_End := Pos; + Next_Char; + end loop; + + end if; + + -- Check for exponent part + + if Pos.Index <= Text'Last + and then (Text (Pos.Index) = 'e' or else Text (Pos.Index) = 'E') + then + Token_End := Pos; + Next_Char; + if Pos.Index > Text'Last then + Error ("invalid number"); + end if; + + if Text (Pos.Index) = '-' then + -- Also a few corner cases can lead to an integer, assume + -- that the number is not an integer. + + Can_Be_Integer := False; + end if; + + if Text (Pos.Index) = '-' or else Text (Pos.Index) = '+' then + Next_Char; + end if; + + if Pos.Index > Text'Last + or else Text (Pos.Index) not in '0' .. '9' + then + Error ("invalid number"); + end if; + + while Pos.Index <= Text'Last + and then Text (Pos.Index) in '0' .. '9' + loop + Token_End := Pos; + Next_Char; + end loop; + end if; + + if Is_Token_Sep then + -- Valid decimal number + + if Can_Be_Integer then + Kind := J_INTEGER; + else + Kind := J_NUMBER; + end if; + return; + else + Error ("invalid number"); + end if; + elsif CC = EOF then + Kind := J_EOF; + else + Error ("Unexpected character"); + end if; + end Read_Token; + + ---------------------------- + -- Read_Token_And_Error -- + ---------------------------- + + procedure Read_Token_And_Error + (TK : Token_Kind; + Token_Start : out Text_Position; + Token_End : out Text_Position) + is + Kind : Token_Kind; + + begin + -- Read a token and errout out if not of the expected kind + + Read_Token (Kind, Token_Start, Token_End); + if Kind /= TK then + Error ("specific token expected"); + end if; + end Read_Token_And_Error; + + ------------------------- + -- Read_Variant_Part -- + ------------------------- + + function Read_Variant_Part return Nat is + Next : Nat := 0; + TK : Token_Kind; + Token_Start : Text_Position; + Token_End : Text_Position; + Var : JSON_Variant_Node; + + begin + -- Read a non-empty array of components + + Read_Token_And_Error (J_ARRAY, Token_Start, Token_End); + + loop + Read_Token_And_Error (J_OBJECT, Token_Start, Token_End); + + Var.Variant := 0; + + -- Read the members as string : value pairs + + loop + case Read_String is + when Name_Present => + Var.Present := Read_Numerical_Expr; + when Name_Record => + Read_Record; + when Name_Variant => + Var.Variant := Read_Variant_Part; + when others => + Error ("invalid variant"); + end case; + + Read_Token (TK, Token_Start, Token_End); + if TK = J_OBJECT_END then + exit; + elsif TK /= J_COMMA then + Error ("comma expected"); + end if; + end loop; + + -- Chain the variant and store it into the table + + Var.Next := Next; + JSON_Variant_Table.Append (Var); + Next := JSON_Variant_Table.Last; + + Read_Token (TK, Token_Start, Token_End); + if TK = J_ARRAY_END then + exit; + elsif TK /= J_COMMA then + Error ("comma expected"); + end if; + end loop; + + return Next; + end Read_Variant_Part; + + ------------------ + -- Skip_Value -- + ------------------ + + procedure Skip_Value is + Array_Depth : Natural := 0; + Object_Depth : Natural := 0; + TK : Token_Kind; + Token_Start : Text_Position; + Token_End : Text_Position; + + begin + -- Read a value without recursing + + loop + Read_Token (TK, Token_Start, Token_End); + + case TK is + when J_STRING | J_INTEGER | J_NUMBER => + null; + when J_ARRAY => + Array_Depth := Array_Depth + 1; + when J_ARRAY_END => + Array_Depth := Array_Depth - 1; + when J_OBJECT => + Object_Depth := Object_Depth + 1; + when J_OBJECT_END => + Object_Depth := Object_Depth - 1; + when J_COLON | J_COMMA => + if Array_Depth = 0 and then Object_Depth = 0 then + Error ("value expected"); + end if; + when others => + Error ("value expected"); + end case; + + exit when Array_Depth = 0 and then Object_Depth = 0; + end loop; + end Skip_Value; + + Token_Start : Text_Position; + Token_End : Text_Position; + TK : Token_Kind; + Is_First : Boolean := True; + + -- Start of processing for Read_JSON_Stream + + begin + -- Read a possibly empty array of entities + + Read_Token_And_Error (J_ARRAY, Token_Start, Token_End); + + loop + Read_Token (TK, Token_Start, Token_End); + if Is_First and then TK = J_ARRAY_END then + exit; + elsif TK /= J_OBJECT then + Error ("object expected"); + end if; + + Read_Entity; + + Read_Token (TK, Token_Start, Token_End); + if TK = J_ARRAY_END then + exit; + elsif TK /= J_COMMA then + Error ("comma expected"); + end if; + + Is_First := False; + end loop; + end Read_JSON_Stream; + +end Repinfo.Input; diff --git a/gcc/ada/repinfo-input.ads b/gcc/ada/repinfo-input.ads new file mode 100644 index 0000000..e418feb --- /dev/null +++ b/gcc/ada/repinfo-input.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- R E P I N F O - I N P U T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2018-2019, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an alternate way of populating the internal tables +-- of Repinfo from a JSON input rather than the binary blob of the tree file. +-- Note that this is an additive mechanism, i.e. nothing is destroyed in the +-- internal state of the unit when it is used. + +-- The first step is to feed the unit with a JSON stream of a specified format +-- (see the spec of Repinfo for its description) by means of Read_JSON_Stream. +-- Then, for each entity whose representation information is present in the +-- JSON stream, the appropriate Get_JSON_* routines can be invoked to override +-- the eponymous fields of the entity in the tree. + +package Repinfo.Input is + + function Get_JSON_Esize (Name : String) return Node_Ref_Or_Val; + -- Returns the Esize value of the entity specified by Name, which is not + -- the component of a record type, or else No_Uint if no representation + -- information was supplied for the entity. Name is the full qualified name + -- of the entity in lower case letters. + + function Get_JSON_RM_Size (Name : String) return Node_Ref_Or_Val; + -- Likewise for the RM_Size + + function Get_JSON_Component_Size (Name : String) return Node_Ref_Or_Val; + -- Likewise for the Component_Size of an array type + + function Get_JSON_Component_Bit_Offset + (Name : String; + Record_Name : String) return Node_Ref_Or_Val; + -- Returns the Component_Bit_Offset of the component specified by Name, + -- which is declared in the record type specified by Record_Name, or else + -- No_Uint if no representation information was supplied for the component. + -- Name is the unqualified name of the component whereas Record_Name is the + -- full qualified name of the record type, both in lower case letters. + + function Get_JSON_Esize + (Name : String; + Record_Name : String) return Node_Ref_Or_Val; + -- Likewise for the Esize + + Invalid_JSON_Stream : exception; + -- Raised if a format error is detected in the JSON stream + + procedure Read_JSON_Stream (Text : Text_Buffer; File_Name : String); + -- Reads a JSON stream and populates internal tables from it. File_Name is + -- only used in error messages issued by the JSON parser. + +end Repinfo.Input; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 007fe39..77b5c21 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -115,10 +115,9 @@ package body Repinfo is -- Identifier casing for current unit. This is set by List_Rep_Info for -- each unit, before calling subprograms which may read it. - Need_Blank_Line : Boolean; - -- Set True if a blank line is needed before outputting any information for - -- the current entity. Set True when a new entity is processed, and false - -- when the blank line is output. + Need_Separator : Boolean; + -- Set True if a separator is needed before outputting any information for + -- the current entity. ------------------------------ -- Set of Relevant Entities -- @@ -151,10 +150,6 @@ package body Repinfo is -- is used rather than checking the configuration parameter because we do -- not want Repinfo to depend on Targparm (for ASIS) - procedure Blank_Line; - -- Called before outputting anything for an entity. Ensures that - -- a blank line precedes the output for a particular entity. - procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean; @@ -172,6 +167,9 @@ package body Repinfo is procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); -- List representation info for array type Ent + procedure List_Common_Type_Info (Ent : Entity_Id); + -- List common type info (name, size, alignment) for type Ent + procedure List_Linker_Section (Ent : Entity_Id); -- List linker section for Ent (caller has checked that Ent is an entity -- for which the Linker_Section_Pragma field is defined). @@ -179,10 +177,6 @@ package body Repinfo is procedure List_Location (Ent : Entity_Id); -- List location information for Ent - procedure List_Mechanisms (Ent : Entity_Id); - -- List mechanism information for parameters of Ent, which is subprogram, - -- subprogram type, or an entry or entry family. - procedure List_Object_Info (Ent : Entity_Id); -- List representation info for object Ent @@ -195,6 +189,9 @@ package body Repinfo is -- List scalar storage order information for record or array type Ent. -- Also includes bit order information for record types, if necessary. + procedure List_Subprogram_Info (Ent : Entity_Id); + -- List subprogram info for subprogram Ent + procedure List_Type_Info (Ent : Entity_Id); -- List type info for type Ent @@ -215,6 +212,10 @@ package body Repinfo is procedure Write_Mechanism (M : Mechanism_Type); -- Writes symbolic string for mechanism represented by M + procedure Write_Separator; + -- Called before outputting anything for an entity. Ensures that + -- a separator precedes the output for a particular entity. + procedure Write_Unknown_Val; -- Writes symbolic string for an unknown or non-representable value @@ -236,18 +237,6 @@ package body Repinfo is return Rep_Table.Last > 0; end Back_End_Layout; - ---------------- - -- Blank_Line -- - ---------------- - - procedure Blank_Line is - begin - if Need_Blank_Line then - Write_Eol; - Need_Blank_Line := False; - end if; - end Blank_Line; - ------------------------ -- Create_Discrim_Ref -- ------------------------ @@ -340,13 +329,13 @@ package body Repinfo is procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is begin - Blank_Line; + Write_Separator; if List_Representation_Info_To_JSON then Write_Line ("{"); end if; - List_Type_Info (Ent); + List_Common_Type_Info (Ent); if List_Representation_Info_To_JSON then Write_Line (","); @@ -370,6 +359,81 @@ package body Repinfo is end if; end List_Array_Info; + --------------------------- + -- List_Common_Type_Info -- + --------------------------- + + procedure List_Common_Type_Info (Ent : Entity_Id) is + begin + if List_Representation_Info_To_JSON then + Write_Str (" ""name"": """); + List_Name (Ent); + Write_Line (""","); + List_Location (Ent); + end if; + + -- Do not list size info for unconstrained arrays, not meaningful + + if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then + null; + + else + -- If Esize and RM_Size are the same, list as Size. This is a common + -- case, which we may as well list in simple form. + + if Esize (Ent) = RM_Size (Ent) then + if List_Representation_Info_To_JSON then + Write_Str (" ""Size"": "); + Write_Val (Esize (Ent)); + Write_Line (","); + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + end if; + + -- Otherwise list size values separately + + else + if List_Representation_Info_To_JSON then + Write_Str (" ""Object_Size"": "); + Write_Val (Esize (Ent)); + Write_Line (","); + + Write_Str (" ""Value_Size"": "); + Write_Val (RM_Size (Ent)); + Write_Line (","); + + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Object_Size use "); + Write_Val (Esize (Ent)); + Write_Line (";"); + + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Value_Size use "); + Write_Val (RM_Size (Ent)); + Write_Line (";"); + end if; + end if; + end if; + + if List_Representation_Info_To_JSON then + Write_Str (" ""Alignment"": "); + Write_Val (Alignment (Ent)); + else + Write_Str ("for "); + List_Name (Ent); + Write_Str ("'Alignment use "); + Write_Val (Alignment (Ent)); + Write_Line (";"); + end if; + end List_Common_Type_Info; + ------------------- -- List_Entities -- ------------------- @@ -427,14 +491,11 @@ package body Repinfo is or else Ekind (Ent) = E_Entry_Family) and then not In_Subprogram then - Need_Blank_Line := True; - List_Mechanisms (Ent); + List_Subprogram_Info (Ent); end if; E := First_Entity (Ent); while Present (E) loop - Need_Blank_Line := True; - -- We list entities that come from source (excluding private or -- incomplete types or deferred constants, for which we will list -- the information for the full view). If requested, we also list @@ -457,22 +518,19 @@ package body Repinfo is then if Is_Subprogram (E) then if List_Representation_Info_Mechanisms then - List_Mechanisms (E); + List_Subprogram_Info (E); end if; -- Recurse into entities local to subprogram List_Entities (E, Bytes_Big_Endian, True); - elsif Is_Formal (E) and then In_Subprogram then - null; - elsif Ekind_In (E, E_Entry, E_Entry_Family, E_Subprogram_Type) then if List_Representation_Info_Mechanisms then - List_Mechanisms (E); + List_Subprogram_Info (E); end if; elsif Is_Record_Type (E) then @@ -496,24 +554,22 @@ package body Repinfo is elsif Is_Type (E) then if List_Representation_Info >= 2 then - Blank_Line; - if List_Representation_Info_To_JSON then - Write_Line ("{"); - end if; List_Type_Info (E); - List_Linker_Section (E); - if List_Representation_Info_To_JSON then - Write_Eol; - Write_Line ("}"); - end if; end if; - elsif Ekind_In (E, E_Variable, E_Constant) then - if List_Representation_Info >= 2 then - List_Object_Info (E); + -- Note that formals are not annotated so we skip them here + + elsif Ekind_In (E, E_Constant, + E_Loop_Parameter, + E_Variable) + then + -- The type is relevant for an object + + if List_Representation_Info = 4 and then Is_Itype (Etype (E)) + then + Relevant_Entities.Set (Etype (E), True); end if; - elsif Ekind (E) = E_Loop_Parameter or else Is_Formal (E) then if List_Representation_Info >= 2 then List_Object_Info (E); end if; @@ -530,12 +586,12 @@ package body Repinfo is -- Recurse into bodies - elsif Ekind_In (E, E_Protected_Type, - E_Task_Type, + elsif Ekind_In (E, E_Package_Body, + E_Protected_Body, + E_Protected_Type, E_Subprogram_Body, - E_Package_Body, E_Task_Body, - E_Protected_Body) + E_Task_Type) then List_Entities (E, Bytes_Big_Endian); @@ -842,193 +898,13 @@ package body Repinfo is Write_Line (""","); end List_Location; - --------------------- - -- List_Mechanisms -- - --------------------- - - procedure List_Mechanisms (Ent : Entity_Id) is - First : Boolean := True; - Plen : Natural; - Form : Entity_Id; - - begin - Blank_Line; - - if List_Representation_Info_To_JSON then - Write_Line ("{"); - Write_Str (" ""name"": """); - List_Name (Ent); - Write_Line (""","); - List_Location (Ent); - - Write_Str (" ""Convention"": """); - else - case Ekind (Ent) is - when E_Function => - Write_Str ("function "); - - when E_Operator => - Write_Str ("operator "); - - when E_Procedure => - Write_Str ("procedure "); - - when E_Subprogram_Type => - Write_Str ("type "); - - when E_Entry - | E_Entry_Family - => - Write_Str ("entry "); - - when others => - raise Program_Error; - end case; - - List_Name (Ent); - Write_Str (" declared at "); - Write_Location (Sloc (Ent)); - Write_Eol; - - Write_Str ("convention : "); - end if; - - case Convention (Ent) is - when Convention_Ada => - Write_Str ("Ada"); - - when Convention_Ada_Pass_By_Copy => - Write_Str ("Ada_Pass_By_Copy"); - - when Convention_Ada_Pass_By_Reference => - Write_Str ("Ada_Pass_By_Reference"); - - when Convention_Intrinsic => - Write_Str ("Intrinsic"); - - when Convention_Entry => - Write_Str ("Entry"); - - when Convention_Protected => - Write_Str ("Protected"); - - when Convention_Assembler => - Write_Str ("Assembler"); - - when Convention_C => - Write_Str ("C"); - - when Convention_COBOL => - Write_Str ("COBOL"); - - when Convention_CPP => - Write_Str ("C++"); - - when Convention_Fortran => - Write_Str ("Fortran"); - - when Convention_Stdcall => - Write_Str ("Stdcall"); - - when Convention_Stubbed => - Write_Str ("Stubbed"); - end case; - - if List_Representation_Info_To_JSON then - Write_Line (""","); - Write_Str (" ""formal"": ["); - else - Write_Eol; - end if; - - -- Find max length of formal name - - Plen := 0; - Form := First_Formal (Ent); - while Present (Form) loop - Get_Unqualified_Decoded_Name_String (Chars (Form)); - - if Name_Len > Plen then - Plen := Name_Len; - end if; - - Next_Formal (Form); - end loop; - - -- Output formals and mechanisms - - Form := First_Formal (Ent); - while Present (Form) loop - Get_Unqualified_Decoded_Name_String (Chars (Form)); - Set_Casing (Unit_Casing); - - if List_Representation_Info_To_JSON then - if First then - Write_Eol; - First := False; - else - Write_Line (","); - end if; - - Write_Line (" {"); - Write_Str (" ""name"": """); - Write_Str (Name_Buffer (1 .. Name_Len)); - Write_Line (""","); - - Write_Str (" ""mechanism"": """); - Write_Mechanism (Mechanism (Form)); - Write_Line (""""); - Write_Str (" }"); - else - while Name_Len <= Plen loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ' '; - end loop; - - Write_Str (" "); - Write_Str (Name_Buffer (1 .. Plen + 1)); - Write_Str (": passed by "); - - Write_Mechanism (Mechanism (Form)); - Write_Eol; - end if; - - Next_Formal (Form); - end loop; - - if List_Representation_Info_To_JSON then - Write_Eol; - Write_Str (" ]"); - end if; - - if Ekind (Ent) = E_Function then - if List_Representation_Info_To_JSON then - Write_Line (","); - Write_Str (" ""mechanism"": """); - Write_Mechanism (Mechanism (Ent)); - Write_Str (""""); - else - Write_Str ("returns by "); - Write_Mechanism (Mechanism (Ent)); - Write_Eol; - end if; - end if; - - if not Is_Entry (Ent) then - List_Linker_Section (Ent); - end if; - - if List_Representation_Info_To_JSON then - Write_Eol; - Write_Line ("}"); - end if; - end List_Mechanisms; - --------------- -- List_Name -- --------------- procedure List_Name (Ent : Entity_Id) is + C : Character; + begin -- List the qualified name recursively, except -- at compilation unit level in default mode. @@ -1044,7 +920,16 @@ package body Repinfo is Get_Unqualified_Decoded_Name_String (Chars (Ent)); Set_Casing (Unit_Casing); - Write_Str (Name_Buffer (1 .. Name_Len)); + + -- The name of operators needs to be properly escaped for JSON + + for J in 1 .. Name_Len loop + C := Name_Buffer (J); + if C = '"' and then List_Representation_Info_To_JSON then + Write_Char ('\'); + end if; + Write_Char (C); + end loop; end List_Name; --------------------- @@ -1053,7 +938,7 @@ package body Repinfo is procedure List_Object_Info (Ent : Entity_Id) is begin - Blank_Line; + Write_Separator; if List_Representation_Info_To_JSON then Write_Line ("{"); @@ -1125,6 +1010,12 @@ package body Repinfo is Indent : Natural := 0); -- Internal recursive procedure to display the structural layout + Incomplete_Layout : exception; + -- Exception raised if the layout is incomplete in -gnatc mode + + Not_In_Extended_Main : exception; + -- Exception raised when an ancestor is not declared in the main unit + Max_Name_Length : Natural := 0; Max_Spos_Length : Natural := 0; @@ -1259,7 +1150,7 @@ package body Repinfo is if Ekind (Ent) = E_Discriminant then Spaces (Indent); Write_Str (" ""discriminant"": "); - UI_Write (Discriminant_Number (Ent)); + UI_Write (Discriminant_Number (Ent), Decimal); Write_Line (","); end if; Spaces (Indent); @@ -1290,7 +1181,7 @@ package body Repinfo is Spaces (Max_Spos_Length - 2); if Starting_Position /= Uint_0 then - UI_Write (Starting_Position); + UI_Write (Starting_Position, Decimal); Write_Str (" + "); end if; @@ -1314,7 +1205,7 @@ package body Repinfo is Sbit := Sbit - SSU; end if; - UI_Write (Sbit); + UI_Write (Sbit, Decimal); if List_Representation_Info_To_JSON then Write_Line (", "); @@ -1336,13 +1227,13 @@ package body Repinfo is Lbit := Sbit + Esiz - 1; if List_Representation_Info_To_JSON then - UI_Write (Esiz); + UI_Write (Esiz, Decimal); else if Lbit >= 0 and then Lbit < 10 then Write_Char (' '); end if; - UI_Write (Lbit); + UI_Write (Lbit, Decimal); end if; -- The test for Esize (Ent) not Uint_0 here is an annoying special @@ -1564,14 +1455,29 @@ package body Repinfo is Disc : Entity_Id; Listed_Disc : Entity_Id; + Parent_Type : Entity_Id; begin -- If this is an extension, first list the layout of the parent -- and then proceed to the extension part, if any. if Is_Extension then - List_Structural_Record_Layout - (Base_Type (Parent_Subtype (Ent)), Outer_Ent); + Parent_Type := Parent_Subtype (Ent); + if No (Parent_Type) then + raise Incomplete_Layout; + end if; + + if Is_Private_Type (Parent_Type) then + Parent_Type := Full_View (Parent_Type); + pragma Assert (Present (Parent_Type)); + end if; + + Parent_Type := Base_Type (Parent_Type); + if not In_Extended_Main_Source_Unit (Parent_Type) then + raise Not_In_Extended_Main; + end if; + + List_Structural_Record_Layout (Parent_Type, Outer_Ent); First := False; if Present (Record_Extension_Part (Definition)) then @@ -1714,13 +1620,13 @@ package body Repinfo is -- Start of processing for List_Record_Info begin - Blank_Line; + Write_Separator; if List_Representation_Info_To_JSON then Write_Line ("{"); end if; - List_Type_Info (Ent); + List_Common_Type_Info (Ent); -- First find out max line length and max starting position -- length, for the purpose of lining things up nicely. @@ -1733,8 +1639,23 @@ package body Repinfo is Write_Line (","); Write_Str (" ""record"": ["); + -- ??? We can output structural layout only for base types fully + -- declared in the extended main source unit for the time being, + -- because otherwise declarations might not be processed at all. + if Is_Base_Type (Ent) then - List_Structural_Record_Layout (Ent, Ent); + begin + List_Structural_Record_Layout (Ent, Ent); + + exception + when Incomplete_Layout + | Not_In_Extended_Main + => + List_Record_Layout (Ent); + + when others => + raise Program_Error; + end; else List_Record_Layout (Ent); end if; @@ -1772,6 +1693,15 @@ package body Repinfo is if List_Representation_Info /= 0 or else List_Representation_Info_Mechanisms then + -- For the normal case, we output a single JSON stream + + if not List_Representation_Info_To_File + and then List_Representation_Info_To_JSON + then + Write_Line ("["); + Need_Separator := False; + end if; + for U in Main_Unit .. Last_Unit loop if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then Unit_Casing := Identifier_Casing (Source_Index (U)); @@ -1795,6 +1725,7 @@ package body Repinfo is end loop; Write_Eol; + Need_Separator := True; end if; List_Entities (Cunit_Entity (U), Bytes_Big_Endian); @@ -1805,12 +1736,25 @@ package body Repinfo is Create_Repinfo_File_Access.all (Get_Name_String (File_Name (Source_Index (U)))); Set_Special_Output (Write_Info_Line'Access); + if List_Representation_Info_To_JSON then + Write_Line ("["); + end if; + Need_Separator := False; List_Entities (Cunit_Entity (U), Bytes_Big_Endian); + if List_Representation_Info_To_JSON then + Write_Line ("]"); + end if; Cancel_Special_Output; Close_Repinfo_File_Access.all; end if; end if; end loop; + + if not List_Representation_Info_To_File + and then List_Representation_Info_To_JSON + then + Write_Line ("]"); + end if; end if; end List_Rep_Info; @@ -1889,79 +1833,201 @@ package body Repinfo is end if; end List_Scalar_Storage_Order; - -------------------- - -- List_Type_Info -- - -------------------- + -------------------------- + -- List_Subprogram_Info -- + -------------------------- + + procedure List_Subprogram_Info (Ent : Entity_Id) is + First : Boolean := True; + Plen : Natural; + Form : Entity_Id; - procedure List_Type_Info (Ent : Entity_Id) is begin + Write_Separator; + if List_Representation_Info_To_JSON then + Write_Line ("{"); Write_Str (" ""name"": """); List_Name (Ent); Write_Line (""","); List_Location (Ent); + + Write_Str (" ""Convention"": """); + else + case Ekind (Ent) is + when E_Function => + Write_Str ("function "); + + when E_Operator => + Write_Str ("operator "); + + when E_Procedure => + Write_Str ("procedure "); + + when E_Subprogram_Type => + Write_Str ("type "); + + when E_Entry + | E_Entry_Family + => + Write_Str ("entry "); + + when others => + raise Program_Error; + end case; + + List_Name (Ent); + Write_Str (" declared at "); + Write_Location (Sloc (Ent)); + Write_Eol; + + Write_Str ("convention : "); end if; - -- Do not list size info for unconstrained arrays, not meaningful + case Convention (Ent) is + when Convention_Ada => + Write_Str ("Ada"); - if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then - null; + when Convention_Ada_Pass_By_Copy => + Write_Str ("Ada_Pass_By_Copy"); + + when Convention_Ada_Pass_By_Reference => + Write_Str ("Ada_Pass_By_Reference"); + + when Convention_Intrinsic => + Write_Str ("Intrinsic"); + + when Convention_Entry => + Write_Str ("Entry"); + + when Convention_Protected => + Write_Str ("Protected"); + when Convention_Assembler => + Write_Str ("Assembler"); + + when Convention_C => + Write_Str ("C"); + + when Convention_COBOL => + Write_Str ("COBOL"); + + when Convention_CPP => + Write_Str ("C++"); + + when Convention_Fortran => + Write_Str ("Fortran"); + + when Convention_Stdcall => + Write_Str ("Stdcall"); + + when Convention_Stubbed => + Write_Str ("Stubbed"); + end case; + + if List_Representation_Info_To_JSON then + Write_Line (""","); + Write_Str (" ""formal"": ["); else - -- If Esize and RM_Size are the same, list as Size. This is a common - -- case, which we may as well list in simple form. + Write_Eol; + end if; - if Esize (Ent) = RM_Size (Ent) then - if List_Representation_Info_To_JSON then - Write_Str (" ""Size"": "); - Write_Val (Esize (Ent)); - Write_Line (","); + -- Find max length of formal name + + Plen := 0; + Form := First_Formal (Ent); + while Present (Form) loop + Get_Unqualified_Decoded_Name_String (Chars (Form)); + + if Name_Len > Plen then + Plen := Name_Len; + end if; + + Next_Formal (Form); + end loop; + + -- Output formals and mechanisms + + Form := First_Formal (Ent); + while Present (Form) loop + Get_Unqualified_Decoded_Name_String (Chars (Form)); + Set_Casing (Unit_Casing); + + if List_Representation_Info_To_JSON then + if First then + Write_Eol; + First := False; else - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Size use "); - Write_Val (Esize (Ent)); - Write_Line (";"); + Write_Line (","); end if; - -- Otherwise list size values separately + Write_Line (" {"); + Write_Str (" ""name"": """); + Write_Str (Name_Buffer (1 .. Name_Len)); + Write_Line (""","); + Write_Str (" ""mechanism"": """); + Write_Mechanism (Mechanism (Form)); + Write_Line (""""); + Write_Str (" }"); else - if List_Representation_Info_To_JSON then - Write_Str (" ""Object_Size"": "); - Write_Val (Esize (Ent)); - Write_Line (","); + while Name_Len <= Plen loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := ' '; + end loop; - Write_Str (" ""Value_Size"": "); - Write_Val (RM_Size (Ent)); - Write_Line (","); + Write_Str (" "); + Write_Str (Name_Buffer (1 .. Plen + 1)); + Write_Str (": passed by "); - else - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Object_Size use "); - Write_Val (Esize (Ent)); - Write_Line (";"); + Write_Mechanism (Mechanism (Form)); + Write_Eol; + end if; - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Value_Size use "); - Write_Val (RM_Size (Ent)); - Write_Line (";"); - end if; + Next_Formal (Form); + end loop; + + if List_Representation_Info_To_JSON then + Write_Eol; + Write_Str (" ]"); + end if; + + if Ekind (Ent) = E_Function then + if List_Representation_Info_To_JSON then + Write_Line (","); + Write_Str (" ""mechanism"": """); + Write_Mechanism (Mechanism (Ent)); + Write_Str (""""); + else + Write_Str ("returns by "); + Write_Mechanism (Mechanism (Ent)); + Write_Eol; end if; end if; + if not Is_Entry (Ent) then + List_Linker_Section (Ent); + end if; + if List_Representation_Info_To_JSON then - Write_Str (" ""Alignment"": "); - Write_Val (Alignment (Ent)); - else - Write_Str ("for "); - List_Name (Ent); - Write_Str ("'Alignment use "); - Write_Val (Alignment (Ent)); - Write_Line (";"); + Write_Eol; + Write_Line ("}"); end if; + end List_Subprogram_Info; + + -------------------- + -- List_Type_Info -- + -------------------- + + procedure List_Type_Info (Ent : Entity_Id) is + begin + Write_Separator; + + if List_Representation_Info_To_JSON then + Write_Line ("{"); + end if; + + List_Common_Type_Info (Ent); -- Special stuff for fixed-point @@ -2010,6 +2076,13 @@ package body Repinfo is end if; end; end if; + + List_Linker_Section (Ent); + + if List_Representation_Info_To_JSON then + Write_Eol; + Write_Line ("}"); + end if; end List_Type_Info; ---------------------- @@ -2284,6 +2357,23 @@ package body Repinfo is end case; end Write_Mechanism; + --------------------- + -- Write_Separator -- + --------------------- + + procedure Write_Separator is + begin + if Need_Separator then + if List_Representation_Info_To_JSON then + Write_Line (","); + else + Write_Eol; + end if; + else + Need_Separator := True; + end if; + end Write_Separator; + ----------------------- -- Write_Unknown_Val -- ----------------------- @@ -2324,7 +2414,7 @@ package body Repinfo is end if; else - UI_Write (Val); + UI_Write (Val, Decimal); end if; end Write_Val; diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index c013721..c51948e 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -193,7 +193,7 @@ package Repinfo is -- following description, the terminology is that of the JSON syntax -- from the ECMA document and of the JSON grammar from www.json.org. - -- The output is a concatenation of entities + -- The output is an array of entities -- An entity is an object whose members are pairs taken from: diff --git a/gcc/ada/rtinit.c b/gcc/ada/rtinit.c index 13bd595..5c9c5ec 100644 --- a/gcc/ada/rtinit.c +++ b/gcc/ada/rtinit.c @@ -41,8 +41,6 @@ #endif #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" /* We don't have libiberty, so use malloc. */ #define xmalloc(S) malloc (S) #define xrealloc(V,S) realloc (V,S) @@ -62,7 +60,7 @@ extern "C" { /* __gnat_runtime_initialize (NT-mingw32 Version) */ /**************************************************/ -extern void __gnat_install_handler(void); +extern void __gnat_install_handler (void); int __gnat_wide_text_translation_required = 0; /* wide text translation, 0=none, 1=activated */ @@ -89,6 +87,189 @@ extern HANDLE ProcListEvt; int __gnat_do_argv_expansion = 1; #pragma weak __gnat_do_argv_expansion +/* Assuming we are pointing to the beginning of a quoted part of an +argument, skip until the end of the quoted part. */ +static void skip_quoted_string (const WCHAR **current_in, + WCHAR **current_out) +{ + /* Number of backslashes buffered. */ + int qbs_count = 0; + + /* Pointer to current input character. */ + const WCHAR *ci = *current_in; + + /* Pointer to next output character. */ + WCHAR *co = *current_out; + + /* Skip initial quote. */ + ci++; + + while (*ci) + { + if (*ci == '\\') + { + /* Buffer incoming backslashes. */ + qbs_count++; + } + else if (*ci == '"') + { + /* Append qbs_count / 2 backslahes. */ + for (int i=0; i<qbs_count / 2; i++) + { + *co = '\\'; + co++; + } + if ((qbs_count & 1) == 0) + { + /* 2n backslashes means that the quotation mark is the end of + the quoted portion. */ + qbs_count = 0; + break; + } + else + { + /* Otherwise this is a double quote literal. */ + qbs_count = 0; + *co = '"'; co++; + } + } + else + { + /* If the character is not a double quote we should append + qbs_count backslashes. */ + for (int i=0; i<qbs_count; i++) + { + *co = '\\'; + co++; + } + *co = *ci; co++; + qbs_count = 0; + } + ci++; + } + *current_in = ci; + *current_out = co; +} + +/* Assuming that this is the beginning of an argument. Skip characters + until we reach the character right after the last argument character. */ +static void skip_argument (const WCHAR **current_in, + WCHAR **current_out) +{ + /* Number of backslashes buffered. */ + int bs_count = 0; + + /* Pointer to current input character. */ + const WCHAR *ci = *current_in; + + /* Pointer to next output character. */ + WCHAR *co = *current_out; + + while (*ci && ! (*ci == ' ' || *ci == '\t')) + { + if (*ci == '\\') + { + /* Buffer incoming backslashes. */ + bs_count++; + } + else if (*ci == '"') + { + /* Append qbs_count / 2 backslahes. */ + for (int i=0; i< bs_count / 2; i++) + { + *co = '\\'; co++; + } + if ((bs_count & 1) == 0) + { + /* 2n backslashes followed by a quotation mark means that + this is a start of a quoted string. */ + skip_quoted_string (&ci, &co); + } + else + { + /* Otherwise this is quotation mark literal. */ + *co = '"'; + co++; + } + bs_count = 0; + } + else + { + /* This is a regular character. */ + /* Backslashes are interpreted literally. */ + for (int i=0; i<bs_count; i++) + { + *co = '\\'; + co++; + } + bs_count = 0; + *co = *ci; co++; + } + ci++; + } + + for (int i=0; i<bs_count; i++) + { + *co = '\\'; + co++; + } + + /* End the argument with a null character. */ + *co = '\0'; + co++; + + *current_in = ci; + *current_out = co; +} + + +void __gnat_get_argw (const WCHAR *command_line, WCHAR ***argv, int *argc) +{ + WCHAR *inline_argv; + WCHAR *co; + int arg_count = 1; + const WCHAR *ci; + + inline_argv = + (WCHAR *) xmalloc ((wcslen (command_line) + 1) * sizeof (WCHAR)); + co = inline_argv; + + /* Start iteration on command line characters. */ + ci = command_line; + + /* Skip command name. Note that if the command line starts with whitechars + then the command name will be the empty string. */ + skip_argument (&ci, &co); + + /* Count remaining arguments. */ + while (*ci) + { + /* skip whitechar */ + while (*ci && (*ci == ' ' || *ci == '\t')) { ci++; } + if (*ci) + { + skip_argument (&ci, &co); + arg_count++; + } + else + break; + } + + /* Allocate table with pointer to each arguments */ + argv[0] = (WCHAR **) xmalloc (arg_count * sizeof (WCHAR *)); + + for (int idx = 0; idx < arg_count; idx++) + { + argv[0][idx] = inline_argv; + while (*inline_argv) + { + inline_argv++; + } + inline_argv++; + } + *argc = arg_count; +} + static void append_arg (int *index, LPWSTR dir, LPWSTR value, char ***argv, int *last, int quoted) @@ -102,14 +283,14 @@ append_arg (int *index, LPWSTR dir, LPWSTR value, { /* no dir prefix */ dirlen = 0; - fullvalue = (LPWSTR) xmalloc ((vallen + 1) * sizeof(TCHAR)); + fullvalue = (LPWSTR) xmalloc ((vallen + 1) * sizeof (TCHAR)); } else { /* Add dir first */ dirlen = _tcslen (dir); - fullvalue = (LPWSTR) xmalloc ((dirlen + vallen + 1) * sizeof(TCHAR)); + fullvalue = (LPWSTR) xmalloc ((dirlen + vallen + 1) * sizeof (TCHAR)); _tcscpy (fullvalue, dir); } @@ -118,7 +299,7 @@ append_arg (int *index, LPWSTR dir, LPWSTR value, if (quoted) { _tcsncpy (fullvalue + dirlen, value + 1, vallen - 1); - fullvalue [dirlen + vallen - sizeof(TCHAR)] = _T('\0'); + fullvalue [dirlen + vallen - sizeof (TCHAR)] = _T ('\0'); } else _tcscpy (fullvalue + dirlen, value); @@ -130,7 +311,7 @@ append_arg (int *index, LPWSTR dir, LPWSTR value, } size = WS2SC (NULL, fullvalue, 0); - (*argv)[*index] = (char *) xmalloc (size + sizeof(TCHAR)); + (*argv)[*index] = (char *) xmalloc (size + sizeof (TCHAR)); WS2SC ((*argv)[*index], fullvalue, size); free (fullvalue); @@ -140,7 +321,7 @@ append_arg (int *index, LPWSTR dir, LPWSTR value, #endif void -__gnat_runtime_initialize(int install_handler) +__gnat_runtime_initialize (int install_handler) { /* increment the reference counter */ @@ -223,7 +404,7 @@ __gnat_runtime_initialize(int install_handler) TCHAR result [MAX_PATH]; int quoted; - wargv = CommandLineToArgvW (GetCommandLineW(), &wargc); + __gnat_get_argw (GetCommandLineW (), &wargv, &wargc); if (wargv != NULL) { @@ -297,7 +478,8 @@ __gnat_runtime_initialize(int install_handler) } } - LocalFree (wargv); + free (wargv[0]); + free (wargv); gnat_argc = argc_expanded; gnat_argv = (char **) xrealloc (gnat_argv, argc_expanded * sizeof (char *)); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 47ad874..eab6f4f 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -2755,23 +2755,23 @@ package Rtsfind is RE_W_WC => System_Stream_Attributes, RE_W_WWC => System_Stream_Attributes, - RE_Storage_Array_Input => System_Strings_Stream_Ops, - RE_Storage_Array_Input_Blk_IO => System_Strings_Stream_Ops, - RE_Storage_Array_Output => System_Strings_Stream_Ops, - RE_Storage_Array_Output_Blk_IO => System_Strings_Stream_Ops, - RE_Storage_Array_Read => System_Strings_Stream_Ops, - RE_Storage_Array_Read_Blk_IO => System_Strings_Stream_Ops, - RE_Storage_Array_Write => System_Strings_Stream_Ops, - RE_Storage_Array_Write_Blk_IO => System_Strings_Stream_Ops, - - RE_Stream_Element_Array_Input => System_Strings_Stream_Ops, - RE_Stream_Element_Array_Input_Blk_IO => System_Strings_Stream_Ops, - RE_Stream_Element_Array_Output => System_Strings_Stream_Ops, - RE_Stream_Element_Array_Output_Blk_IO => System_Strings_Stream_Ops, - RE_Stream_Element_Array_Read => System_Strings_Stream_Ops, - RE_Stream_Element_Array_Read_Blk_IO => System_Strings_Stream_Ops, - RE_Stream_Element_Array_Write => System_Strings_Stream_Ops, - RE_Stream_Element_Array_Write_Blk_IO => System_Strings_Stream_Ops, + RE_Storage_Array_Input => System_Strings_Stream_Ops, + RE_Storage_Array_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Storage_Array_Output => System_Strings_Stream_Ops, + RE_Storage_Array_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Storage_Array_Read => System_Strings_Stream_Ops, + RE_Storage_Array_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Storage_Array_Write => System_Strings_Stream_Ops, + RE_Storage_Array_Write_Blk_IO => System_Strings_Stream_Ops, + + RE_Stream_Element_Array_Input => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Input_Blk_IO => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Output => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Output_Blk_IO => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Read => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Read_Blk_IO => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Write => System_Strings_Stream_Ops, + RE_Stream_Element_Array_Write_Blk_IO => System_Strings_Stream_Ops, RE_String_Input => System_Strings_Stream_Ops, RE_String_Input_Blk_IO => System_Strings_Stream_Ops, diff --git a/gcc/ada/runtime.h b/gcc/ada/runtime.h new file mode 100644 index 0000000..df42730 --- /dev/null +++ b/gcc/ada/runtime.h @@ -0,0 +1,44 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * RUNTIME * + * * + * C Header File * + * * + * Copyright (C) 2019, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * <http://www.gnu.org/licenses/>. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This file provides common definitions used by GNAT C runtime files. */ + +#ifdef __vxworks +#include "vxWorks.h" +#endif /* __vxworks */ + +#ifndef ATTRIBUTE_UNUSED +#define ATTRIBUTE_UNUSED __attribute__((unused)) +#endif + +#ifndef ATTRIBUTE_NORETURN +#define ATTRIBUTE_NORETURN __attribute__((noreturn)) +#endif diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index f63ea52..655d68a 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -261,6 +261,14 @@ main (void) { TXT("-- This is the version for " TARGET) TXT("") TXT("with Interfaces.C;") +#if defined (__MINGW32__) +# define TARGET_OS "Windows" +# define Serial_Port_Descriptor "System.Win32.HANDLE" +TXT("with System.Win32;") +#else +# define TARGET_OS "Other_OS" +# define Serial_Port_Descriptor "Interfaces.C.int" +#endif /* package System.OS_Constants is @@ -280,11 +288,6 @@ package System.OS_Constants is type OS_Type is (Windows, Other_OS); */ -#if defined (__MINGW32__) -# define TARGET_OS "Windows" -#else -# define TARGET_OS "Other_OS" -#endif C("Target_OS", OS_Type, TARGET_OS, "") /* pragma Warnings (Off, Target_OS); @@ -303,6 +306,8 @@ CST(Target_Name, "") #define SIZEOF_unsigned_int sizeof (unsigned int) CND(SIZEOF_unsigned_int, "Size of unsigned int") +SUB(Serial_Port_Descriptor) + /* ------------------- @@ -405,10 +410,10 @@ CND(FNDELAY, "Nonblocking") #if defined (__FreeBSD__) || defined (__DragonFly__) # define CNI CNU -# define IOCTL_Req_T "unsigned" +# define IOCTL_Req_T "Interfaces.C.unsigned" #else # define CNI CND -# define IOCTL_Req_T "int" +# define IOCTL_Req_T "Interfaces.C.int" #endif SUB(IOCTL_Req_T) @@ -1287,6 +1292,111 @@ CND(IPPROTO_UDP, "UDP") #endif CND(IPPROTO_TCP, "TCP") +#ifndef IPPROTO_ICMP +# define IPPROTO_ICMP -1 +#endif +CND(IPPROTO_ICMP, "Internet Control Message Protocol") + +#ifndef IPPROTO_IGMP +# define IPPROTO_IGMP -1 +#endif +CND(IPPROTO_IGMP, "Internet Group Management Protocol") + +#ifndef IPPROTO_IPIP +# define IPPROTO_IPIP -1 +#endif +CND(IPPROTO_IPIP, "IPIP tunnels (older KA9Q tunnels use 94)") + +#ifndef IPPROTO_EGP +# define IPPROTO_EGP -1 +#endif +CND(IPPROTO_EGP, "Exterior Gateway Protocol") + +#ifndef IPPROTO_PUP +# define IPPROTO_PUP -1 +#endif +CND(IPPROTO_PUP, "PUP protocol") + +#ifndef IPPROTO_IDP +# define IPPROTO_IDP -1 +#endif +CND(IPPROTO_IDP, "XNS IDP protocol") + +#ifndef IPPROTO_TP +# define IPPROTO_TP -1 +#endif +CND(IPPROTO_TP, "SO Transport Protocol Class 4") + +#ifndef IPPROTO_DCCP +# define IPPROTO_DCCP -1 +#endif +CND(IPPROTO_DCCP, "Datagram Congestion Control Protocol") + +#ifndef IPPROTO_RSVP +# define IPPROTO_RSVP -1 +#endif +CND(IPPROTO_RSVP, "Reservation Protocol") + +#ifndef IPPROTO_GRE +# define IPPROTO_GRE -1 +#endif +CND(IPPROTO_GRE, "General Routing Encapsulation") + +#ifndef IPPROTO_ESP +# define IPPROTO_ESP -1 +#endif +CND(IPPROTO_ESP, "encapsulating security payload") + +#ifndef IPPROTO_AH +# define IPPROTO_AH -1 +#endif +CND(IPPROTO_AH, "authentication header") + +#ifndef IPPROTO_MTP +# define IPPROTO_MTP -1 +#endif +CND(IPPROTO_MTP, "Multicast Transport Protocol") + +#ifndef IPPROTO_BEETPH +# define IPPROTO_BEETPH -1 +#endif +CND(IPPROTO_BEETPH, "IP option pseudo header for BEET") + +#ifndef IPPROTO_ENCAP +# define IPPROTO_ENCAP -1 +#endif +CND(IPPROTO_ENCAP, "Encapsulation Header") + +#ifndef IPPROTO_PIM +# define IPPROTO_PIM -1 +#endif +CND(IPPROTO_PIM, "Protocol Independent Multicast") + +#ifndef IPPROTO_COMP +# define IPPROTO_COMP -1 +#endif +CND(IPPROTO_COMP, "Compression Header Protocol") + +#ifndef IPPROTO_SCTP +# define IPPROTO_SCTP -1 +#endif +CND(IPPROTO_SCTP, "Stream Control Transmission Protocol") + +#ifndef IPPROTO_UDPLITE +# define IPPROTO_UDPLITE -1 +#endif +CND(IPPROTO_UDPLITE, "UDP-Lite protocol") + +#ifndef IPPROTO_MPLS +# define IPPROTO_MPLS -1 +#endif +CND(IPPROTO_MPLS, "MPLS in IP") + +#ifndef IPPROTO_RAW +# define IPPROTO_RAW -1 +#endif +CND(IPPROTO_RAW, "Raw IP packets") + /* ------------------- @@ -1628,9 +1738,9 @@ CND(IF_NAMESIZE, "Max size of interface name with 0 terminator"); */ #if defined (__sun__) || defined (__hpux__) -# define Msg_Iovlen_T "int" +# define Msg_Iovlen_T "Interfaces.C.int" #else -# define Msg_Iovlen_T "size_t" +# define Msg_Iovlen_T "Interfaces.C.size_t" #endif SUB(Msg_Iovlen_T) diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb index 58efe51..841206d 100644 --- a/gcc/ada/scil_ll.adb +++ b/gcc/ada/scil_ll.adb @@ -49,25 +49,6 @@ package body SCIL_LL is -- Internal Hash Tables -- -------------------------- - package Contract_Only_Body_Flag is new Simple_HTable - (Header_Num => Header_Num, - Element => Boolean, - No_Element => False, - Key => Node_Id, - Hash => Hash, - Equal => "="); - -- This table records the value of flag Is_Contract_Only_Flag of tree nodes - - package Contract_Only_Body_Nodes is new Simple_HTable - (Header_Num => Header_Num, - Element => Node_Id, - No_Element => Empty, - Key => Node_Id, - Hash => Hash, - Equal => "="); - -- This table records the value of attribute Contract_Only_Body of tree - -- nodes. - package SCIL_Nodes is new Simple_HTable (Header_Num => Header_Num, Element => Node_Id, @@ -86,21 +67,6 @@ package body SCIL_LL is Set_SCIL_Node (Target, Get_SCIL_Node (Source)); end Copy_SCIL_Node; - ---------------------------- - -- Get_Contract_Only_Body -- - ---------------------------- - - function Get_Contract_Only_Body (N : Node_Id) return Node_Id is - begin - if CodePeer_Mode - and then Present (N) - then - return Contract_Only_Body_Nodes.Get (N); - else - return Empty; - end if; - end Get_Contract_Only_Body; - ------------------- -- Get_SCIL_Node -- ------------------- @@ -132,42 +98,9 @@ package body SCIL_LL is procedure Initialize is begin SCIL_Nodes.Reset; - Contract_Only_Body_Nodes.Reset; - Contract_Only_Body_Flag.Reset; Set_Reporting_Proc (Copy_SCIL_Node'Access); end Initialize; - --------------------------- - -- Is_Contract_Only_Body -- - --------------------------- - - function Is_Contract_Only_Body (E : Entity_Id) return Boolean is - begin - return Contract_Only_Body_Flag.Get (E); - end Is_Contract_Only_Body; - - ---------------------------- - -- Set_Contract_Only_Body -- - ---------------------------- - - procedure Set_Contract_Only_Body (N : Node_Id; Value : Node_Id) is - begin - pragma Assert (CodePeer_Mode - and then Present (N) - and then Is_Contract_Only_Body (Value)); - - Contract_Only_Body_Nodes.Set (N, Value); - end Set_Contract_Only_Body; - - ------------------------------- - -- Set_Is_Contract_Only_Body -- - ------------------------------- - - procedure Set_Is_Contract_Only_Body (E : Entity_Id) is - begin - Contract_Only_Body_Flag.Set (E, True); - end Set_Is_Contract_Only_Body; - ------------------- -- Set_SCIL_Node -- ------------------- diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads index 81d8260..6246af7 100644 --- a/gcc/ada/scil_ll.ads +++ b/gcc/ada/scil_ll.ads @@ -30,31 +30,19 @@ ------------------------------------------------------------------------------ -- This package extends the tree nodes with fields that are used to reference --- the SCIL node and the Contract_Only_Body of a subprogram with aspects. +-- the SCIL node. with Types; use Types; package SCIL_LL is - function Get_Contract_Only_Body (N : Node_Id) return Node_Id; - -- Read the value of attribute Contract_Only_Body - function Get_SCIL_Node (N : Node_Id) return Node_Id; -- Read the value of attribute SCIL node - procedure Set_Contract_Only_Body (N : Node_Id; Value : Node_Id); - -- Set the value of attribute Contract_Only_Body - procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id); -- Set the value of attribute SCIL node procedure Initialize; -- Initialize the table of SCIL nodes - function Is_Contract_Only_Body (E : Entity_Id) return Boolean; - -- Return True if E is a Contract_Only_Body subprogram - - procedure Set_Is_Contract_Only_Body (E : Entity_Id); - -- Set E as Contract_Only_Body subprogram - end SCIL_LL; diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c index fa9a693..2926605 100644 --- a/gcc/ada/seh_init.c +++ b/gcc/ada/seh_init.c @@ -39,8 +39,8 @@ #endif #ifdef IN_RTS -#include "tconfig.h" -#include "tsystem.h" + +#include "runtime.h" /* We don't have libiberty, so use malloc. */ #define xmalloc(S) malloc (S) diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index fa3ed48..2f8f6a4 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1579,7 +1579,7 @@ package body Sem is and then Nkind (Unit (Comp_Unit)) in N_Proper_Body and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body or else not Acts_As_Spec (Comp_Unit)) - and then not In_Extended_Main_Source_Unit (Comp_Unit) + and then not Ext_Main_Source_Unit then null; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index d03af55..7aacc5f 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -904,7 +904,7 @@ package body Sem_Aggr is -- If the aggregate has box-initialized components, its type must be -- frozen so that initialization procedures can properly be called - -- in the resolution that follows. The replacement of boxes with + -- in the resolution that follows. The replacement of boxes with -- initialization calls is properly an expansion activity but it must -- be done during resolution. @@ -4264,8 +4264,15 @@ package body Sem_Aggr is Expr_Disc : Node_Id) is begin - if Nkind (Bound) = N_Identifier - and then Entity (Bound) = Disc + if Nkind (Bound) /= N_Identifier then + return; + end if; + + -- We expect either the discriminant or the discriminal + + if Entity (Bound) = Disc + or else (Ekind (Entity (Bound)) = E_In_Parameter + and then Discriminal_Link (Entity (Bound)) = Disc) then Rewrite (Bound, New_Copy_Tree (Expr_Disc)); end if; @@ -4280,9 +4287,7 @@ package body Sem_Aggr is -- Start of processing for Rewrite_Range begin - if Has_Discriminants (Root_Type) - and then Nkind (Rge) = N_Range - then + if Has_Discriminants (Root_Type) and then Nkind (Rge) = N_Range then Low := Low_Bound (Rge); High := High_Bound (Rge); @@ -4903,7 +4908,9 @@ package body Sem_Aggr is -- Root record type whose discriminants may be used as -- bounds in range nodes. - Index : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Index : Node_Id; begin -- Rewrite the range nodes occurring in the indexes @@ -4919,12 +4926,26 @@ package body Sem_Aggr is end loop; -- Rewrite the range nodes occurring as aggregate - -- bounds. + -- bounds and component associations. - if Nkind (Expr) = N_Aggregate - and then Present (Aggregate_Bounds (Expr)) - then - Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr)); + if Nkind (Expr) = N_Aggregate then + if Present (Aggregate_Bounds (Expr)) then + Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr)); + end if; + + if Present (Component_Associations (Expr)) then + Assoc := First (Component_Associations (Expr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + Rewrite_Range (Rec_Typ, Choice); + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + end if; end if; end; end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index bdc76c3..4c6cba6 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1634,7 +1634,9 @@ package body Sem_Attr is raise Bad_Attribute; end if; - -- Normal case of array type or subtype + -- Normal case of array type or subtype. Note that if the + -- prefix is a current instance of a type declaration it + -- appears within an aspect specification and is legal. Check_Either_E0_Or_E1; Check_Dereference; @@ -1643,6 +1645,7 @@ package body Sem_Attr is if not Is_Constrained (P_Type) and then Is_Entity_Name (P) and then Is_Type (Entity (P)) + and then not Is_Current_Instance (P) then -- Note: we do not call Error_Attr here, since we prefer to -- continue, using the relevant index type of the array, @@ -5845,8 +5848,19 @@ package body Sem_Attr is or else Ekind (Entity (P)) = E_Enumeration_Literal) and then Size_Known_At_Compile_Time (Entity (P)) then - Rewrite (N, Make_Integer_Literal (Sloc (N), Esize (Entity (P)))); - Analyze (N); + declare + Siz : Uint; + + begin + if Known_Static_RM_Size (Entity (P)) then + Siz := RM_Size (Entity (P)); + else + Siz := Esize (Entity (P)); + end if; + + Rewrite (N, Make_Integer_Literal (Sloc (N), Siz)); + Analyze (N); + end; end if; ----------- @@ -11418,7 +11432,7 @@ package body Sem_Attr is if Present (Lo) then Rewrite (P, Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Prefix (P)), + Prefix => Relocate_Node (Prefix (P)), Expressions => New_List (Lo))); Analyze_And_Resolve (P); diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 0954032..71a3873 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1324,6 +1324,19 @@ package body Sem_Aux is end if; end Is_Limited_View; + ---------------------------- + -- Is_Protected_Operation -- + ---------------------------- + + function Is_Protected_Operation (E : Entity_Id) return Boolean is + begin + return + Is_Entry (E) + or else (Is_Subprogram (E) + and then Nkind (Parent (Unit_Declaration_Node (E))) = + N_Protected_Definition); + end Is_Protected_Operation; + ---------------------- -- Nearest_Ancestor -- ---------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index ec0f5e7..55cfefa 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -87,7 +87,7 @@ package Sem_Aux is ----------------- function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id; - -- The argument Id is a type or subtype entity. If the argument is a + -- The argument Typ is a type or subtype entity. If the argument is a -- subtype then it returns the subtype or type from which the subtype was -- obtained, otherwise it returns Empty. @@ -357,6 +357,10 @@ package Sem_Aux is -- these types). This older routine overlaps with the previous one, this -- should be cleaned up??? + function Is_Protected_Operation (E : Entity_Id) return Boolean; + -- Given a subprogram or entry, determines whether E is a protected entry + -- or subprogram. + function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id; -- Given a subtype Typ, this function finds out the nearest ancestor from -- which constraints and predicates are inherited. There is no simple link diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 407e84f..c5d10f7 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -4355,7 +4355,7 @@ package body Sem_Ch10 is end; end if; - -- The With_Clause may be on a grand-child or one of its further + -- The With_Clause may be on a grandchild or one of its further -- descendants, which makes a child immediately visible. Examine -- ancestry to determine whether such a child exists. For example, -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X @@ -4394,7 +4394,7 @@ package body Sem_Ch10 is -- Scan context of current unit, to check whether there is -- a with_clause on the same unit as a private with-clause -- on a parent, in which case child unit is visible. If the - -- unit is a grand-child, the same applies to its parent. + -- unit is a grandchild, the same applies to its parent. ---------------- -- In_Context -- @@ -6379,22 +6379,38 @@ package body Sem_Ch10 is begin -- Ada 2005 (AI-50217): We remove the context clauses in two phases: - -- limited-views first and regular-views later (to maintain the - -- stack model). + -- limited-views first and regular-views later (to maintain the stack + -- model). -- First Phase: Remove limited_with context clauses Item := First (Context_Items (N)); while Present (Item) loop - -- We are interested only in with clauses which got installed - -- on entry. + -- We are interested only in with clauses that got installed on entry if Nkind (Item) = N_With_Clause and then Limited_Present (Item) - and then Limited_View_Installed (Item) then - Remove_Limited_With_Clause (Item); + if Limited_View_Installed (Item) then + Remove_Limited_With_Clause (Item); + + -- An unusual case: If the library unit of the Main_Unit has a + -- limited with_clause on some unit P and the context somewhere + -- includes a with_clause on P, P has been analyzed. The entity + -- for P is still visible, which in general is harmless because + -- this is the end of the compilation, but it can affect pending + -- instantiations that may have been generated elsewhere, so it + -- it is necessary to remove U from visibility so that inlining + -- and the analysis of instance bodies can proceed cleanly. + + elsif Current_Sem_Unit = Main_Unit + and then Serious_Errors_Detected = 0 + and then not Implicit_With (Item) + then + Set_Is_Immediately_Visible + (Defining_Entity (Unit (Library_Unit (Item))), False); + end if; end if; Next (Item); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 42feab0..3aa4975 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6002,7 +6002,7 @@ package body Sem_Ch12 is Make_Parameter_Specification (Loc, Defining_Identifier => F1, Parameter_Type => New_Occurrence_Of (Op_Type, Loc))), - Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); + Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); if Is_Binary then Append_To (Parameter_Specifications (Spec), @@ -6657,9 +6657,11 @@ package body Sem_Ch12 is Formal_Decl := Parent (Associated_Formal_Package (E)); -- Nothing to check if the formal has a box or an others_clause - -- (necessarily with a box). + -- (necessarily with a box), or no associations altogether - if Box_Present (Formal_Decl) then + if Box_Present (Formal_Decl) + or else No (Generic_Associations (Formal_Decl)) + then null; elsif Nkind (First (Generic_Associations (Formal_Decl))) = @@ -10309,8 +10311,11 @@ package body Sem_Ch12 is begin Analyze (Actual); + -- The actual must be a package instance, or else a current instance + -- such as a parent generic within the body of a generic child. + if not Is_Entity_Name (Actual) - or else Ekind (Entity (Actual)) /= E_Package + or else not Ekind_In (Entity (Actual), E_Generic_Package, E_Package) then Error_Msg_N ("expect package instance to instantiate formal", Actual); @@ -10349,8 +10354,14 @@ package body Sem_Ch12 is ("previous error in declaration of formal package", Actual); Abandon_Instantiation (Actual); - elsif - Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) + elsif Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent)) then + null; + + -- If this is the current instance of an enclosing generic, that unit + -- is the generic package we need. + + elsif In_Open_Scopes (Actual_Pack) + and then Ekind (Actual_Pack) = E_Generic_Package then null; @@ -10412,7 +10423,7 @@ package body Sem_Ch12 is Actual_Ent := First_Entity (Actual_Pack); Actual_Of_Formal := - First (Visible_Declarations (Specification (Analyzed_Formal))); + First (Visible_Declarations (Specification (Analyzed_Formal))); while Present (Actual_Ent) and then Actual_Ent /= First_Private_Entity (Actual_Pack) loop @@ -10487,6 +10498,17 @@ package body Sem_Ch12 is Next_Entity (Actual_Ent); end loop; + + -- No conformance to check if the generic has no formal parameters + -- and the formal package has no generic associations. + + if Is_Empty_List (Formals) + and then + (Box_Present (Formal) + or else No (Generic_Associations (Formal))) + then + return Decls; + end if; end; -- If the formal is not declared with a box, reanalyze it as an @@ -14103,9 +14125,33 @@ package body Sem_Ch12 is ------------------------ procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is + procedure Perform_Appropriate_Analysis (N : Node_Id); + -- Determine if the actuals we are analyzing come from a generic + -- instantiation that is a library unit and dispatch accordingly. + + ---------------------------------- + -- Perform_Appropriate_Analysis -- + ---------------------------------- + + procedure Perform_Appropriate_Analysis (N : Node_Id) is + begin + -- When we have a library instantiation we cannot allow any expansion + -- to occur, since there may be no place to put it. Instead, in that + -- case we perform a preanalysis of the actual. + + if Present (Inst) and then Is_Compilation_Unit (Inst) then + Preanalyze (N); + else + Analyze (N); + end if; + end Perform_Appropriate_Analysis; + + -- Local variables + + Errs : constant Nat := Serious_Errors_Detected; + Assoc : Node_Id; Act : Node_Id; - Errs : constant Nat := Serious_Errors_Detected; Cur : Entity_Id := Empty; -- Current homograph of the instance name @@ -14113,6 +14159,8 @@ package body Sem_Ch12 is Vis : Boolean := False; -- Saved visibility status of the current homograph + -- Start of processing for Preanalyze_Actuals + begin Assoc := First (Generic_Associations (N)); @@ -14154,10 +14202,10 @@ package body Sem_Ch12 is null; elsif Nkind (Act) = N_Attribute_Reference then - Analyze (Prefix (Act)); + Perform_Appropriate_Analysis (Prefix (Act)); elsif Nkind (Act) = N_Explicit_Dereference then - Analyze (Prefix (Act)); + Perform_Appropriate_Analysis (Prefix (Act)); elsif Nkind (Act) = N_Allocator then declare @@ -14165,7 +14213,7 @@ package body Sem_Ch12 is begin if Nkind (Expr) = N_Subtype_Indication then - Analyze (Subtype_Mark (Expr)); + Perform_Appropriate_Analysis (Subtype_Mark (Expr)); -- Analyze separately each discriminant constraint, when -- given with a named association. @@ -14177,9 +14225,10 @@ package body Sem_Ch12 is Constr := First (Constraints (Constraint (Expr))); while Present (Constr) loop if Nkind (Constr) = N_Discriminant_Association then - Analyze (Expression (Constr)); + Perform_Appropriate_Analysis + (Expression (Constr)); else - Analyze (Constr); + Perform_Appropriate_Analysis (Constr); end if; Next (Constr); @@ -14187,12 +14236,12 @@ package body Sem_Ch12 is end; else - Analyze (Expr); + Perform_Appropriate_Analysis (Expr); end if; end; elsif Nkind (Act) /= N_Operator_Symbol then - Analyze (Act); + Perform_Appropriate_Analysis (Act); -- Within a package instance, mark actuals that are limited -- views, so their use can be moved to the body of the @@ -14213,7 +14262,7 @@ package body Sem_Ch12 is -- warnings complaining about the generic being unreferenced, -- before abandoning the instantiation. - Analyze (Name (N)); + Perform_Appropriate_Analysis (Name (N)); if Is_Entity_Name (Name (N)) and then Etype (Name (N)) /= Any_Type diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2a4afb8..bf80200 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -30,7 +30,6 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; -with Expander; use Expander; with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -247,41 +246,6 @@ package body Sem_Ch13 is -- Remove visibility to the discriminants of type entity E and pop the -- scope stack if E has discriminants and is not a subtype. - --------------------------------------------------- - -- Table for Validate_Compile_Time_Warning_Error -- - --------------------------------------------------- - - -- The following table collects pragmas Compile_Time_Error and Compile_ - -- Time_Warning for validation. Entries are made by calls to subprogram - -- Validate_Compile_Time_Warning_Error, and the call to the procedure - -- Validate_Compile_Time_Warning_Errors does the actual error checking - -- and posting of warning and error messages. The reason for this delayed - -- processing is to take advantage of back-annotations of attributes size - -- and alignment values performed by the back end. - - -- Note: the reason we store a Source_Ptr value instead of a Node_Id is - -- that by the time Validate_Unchecked_Conversions is called, Sprint will - -- already have modified all Sloc values if the -gnatD option is set. - - type CTWE_Entry is record - Eloc : Source_Ptr; - -- Source location used in warnings and error messages - - Prag : Node_Id; - -- Pragma Compile_Time_Error or Compile_Time_Warning - - Scope : Node_Id; - -- The scope which encloses the pragma - end record; - - package Compile_Time_Warnings_Errors is new Table.Table ( - Table_Component_Type => CTWE_Entry, - Table_Index_Type => Int, - Table_Low_Bound => 1, - Table_Initial => 50, - Table_Increment => 200, - Table_Name => "Compile_Time_Warnings_Errors"); - ---------------------------------------------- -- Table for Validate_Unchecked_Conversions -- ---------------------------------------------- @@ -3491,14 +3455,32 @@ package body Sem_Ch13 is -- Build the precondition/postcondition pragma - -- Add note about why we do NOT need Copy_Tree here??? + -- We use Relocate_Node here rather than New_Copy_Tree + -- because subsequent visibility analysis of the aspect + -- depends on this sharing. This should be cleaned up??? - Make_Aitem_Pragma - (Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Eloc, - Chars => Name_Check, - Expression => Relocate_Node (Expr))), - Pragma_Name => Pname); + -- If the context is generic or involves ASIS, we want + -- to preserve the original tree, and simply share it + -- between aspect and generated attribute. This parallels + -- what is done in sem_prag.adb (see Get_Argument). + + declare + New_Expr : Node_Id; + + begin + if ASIS_Mode or else Inside_A_Generic then + New_Expr := Expr; + else + New_Expr := Relocate_Node (Expr); + end if; + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Check, + Expression => New_Expr)), + Pragma_Name => Pname); + end; -- Add message unless exception messages are suppressed @@ -5163,6 +5145,7 @@ package body Sem_Ch13 is -- aspect case properly. if Is_Object (O_Ent) + and then not Is_Generic_Formal (O_Ent) and then not Is_Generic_Type (Etype (U_Ent)) and then Address_Clause_Overlay_Warnings then @@ -5511,7 +5494,7 @@ package body Sem_Ch13 is -- Default_Iterator -- ---------------------- - when Attribute_Default_Iterator => Default_Iterator : declare + when Attribute_Default_Iterator => Default_Iterator : declare Func : Entity_Id; Typ : Entity_Id; @@ -8902,9 +8885,15 @@ package body Sem_Ch13 is Expression => Expr)))); -- The declaration has been analyzed when created, and placed - -- after type declaration. Insert body itself after freeze node. + -- after type declaration. Insert body itself after freeze node, + -- unless subprogram declaration is already there, in which case + -- body better be placed afterwards. - Insert_After_And_Analyze (N, FBody); + if FDecl = Next (N) then + Insert_After_And_Analyze (FDecl, FBody); + else + Insert_After_And_Analyze (N, FBody); + end if; -- The defining identifier of a quantified expression carries the -- scope in which the type appears, but when unnesting we need @@ -9352,10 +9341,20 @@ package body Sem_Ch13 is else -- In a generic context freeze nodes are not always generated, so - -- analyze the expression now. + -- analyze the expression now. If the aspect is for a type, this + -- makes its potential components accessible. if not Analyzed (Freeze_Expr) and then Inside_A_Generic then - Preanalyze (Freeze_Expr); + if A_Id = Aspect_Dynamic_Predicate + or else A_Id = Aspect_Predicate + or else A_Id = Aspect_Priority + then + Push_Type (Ent); + Preanalyze (Freeze_Expr); + Pop_Type (Ent); + else + Preanalyze (Freeze_Expr); + end if; end if; -- Indicate that the expression comes from an aspect specification, @@ -9389,6 +9388,7 @@ package body Sem_Ch13 is elsif A_Id = Aspect_Dynamic_Predicate or else A_Id = Aspect_Predicate or else A_Id = Aspect_Priority + or else A_Id = Aspect_CPU then Push_Type (Ent); Preanalyze_Spec_Expression (End_Decl_Expr, T); @@ -11280,6 +11280,7 @@ package body Sem_Ch13 is if A_Id = Aspect_Dynamic_Predicate or else A_Id = Aspect_Predicate or else A_Id = Aspect_Priority + or else A_Id = Aspect_CPU then -- Retrieve the visibility to components and discriminants -- in order to properly analyze the aspects. @@ -11563,7 +11564,7 @@ package body Sem_Ch13 is begin -- A representation item is either subtype-specific (Size and Alignment - -- clauses) or type-related (all others). Subtype-specific aspects may + -- clauses) or type-related (all others). Subtype-specific aspects may -- differ for different subtypes of the same type (RM 13.1.8). -- A derived type inherits each type-related representation aspect of @@ -11796,7 +11797,6 @@ package body Sem_Ch13 is procedure Initialize is begin Address_Clause_Checks.Init; - Compile_Time_Warnings_Errors.Init; Unchecked_Conversions.Init; -- ??? Might be needed in the future for some non GCC back-ends @@ -12550,6 +12550,30 @@ package body Sem_Ch13 is ------------------------ function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is + function Has_Generic_Parent (E : Entity_Id) return Boolean; + -- Return True if any ancestor is a generic type + + ------------------------ + -- Has_Generic_Parent -- + ------------------------ + + function Has_Generic_Parent (E : Entity_Id) return Boolean is + Ancestor_Type : Entity_Id := Etype (E); + + begin + while Present (Ancestor_Type) + and then not Is_Generic_Type (Ancestor_Type) + and then Etype (Ancestor_Type) /= Ancestor_Type + loop + Ancestor_Type := Etype (Ancestor_Type); + end loop; + + return + Present (Ancestor_Type) and then Is_Generic_Type (Ancestor_Type); + end Has_Generic_Parent; + + -- Start of processing for Rep_Item_Too_Early + begin -- Cannot apply non-operational rep items to generic types @@ -12557,7 +12581,7 @@ package body Sem_Ch13 is return False; elsif Is_Type (T) - and then Is_Generic_Type (Root_Type (T)) + and then Has_Generic_Parent (T) and then (Nkind (N) /= N_Pragma or else Get_Pragma_Id (N) /= Pragma_Convention) then @@ -12607,7 +12631,7 @@ package body Sem_Ch13 is function Is_Derived_Type_With_Constraint return Boolean; -- Check whether T is a derived type with an explicit constraint, in -- which case the constraint has frozen the type and the item is too - -- late. This compensates for the fact that for derived scalar types + -- late. This compensates for the fact that for derived scalar types -- we freeze the base type unconditionally on account of a long-standing -- issue in gigi. @@ -13903,79 +13927,6 @@ package body Sem_Ch13 is end loop; end Validate_Address_Clauses; - ----------------------------------------- - -- Validate_Compile_Time_Warning_Error -- - ----------------------------------------- - - procedure Validate_Compile_Time_Warning_Error (N : Node_Id) is - begin - Compile_Time_Warnings_Errors.Append - (New_Val => CTWE_Entry'(Eloc => Sloc (N), - Scope => Current_Scope, - Prag => N)); - end Validate_Compile_Time_Warning_Error; - - ------------------------------------------ - -- Validate_Compile_Time_Warning_Errors -- - ------------------------------------------ - - procedure Validate_Compile_Time_Warning_Errors is - procedure Set_Scope (S : Entity_Id); - -- Install all enclosing scopes of S along with S itself - - procedure Unset_Scope (S : Entity_Id); - -- Uninstall all enclosing scopes of S along with S itself - - --------------- - -- Set_Scope -- - --------------- - - procedure Set_Scope (S : Entity_Id) is - begin - if S /= Standard_Standard then - Set_Scope (Scope (S)); - end if; - - Push_Scope (S); - end Set_Scope; - - ----------------- - -- Unset_Scope -- - ----------------- - - procedure Unset_Scope (S : Entity_Id) is - begin - if S /= Standard_Standard then - Unset_Scope (Scope (S)); - end if; - - Pop_Scope; - end Unset_Scope; - - -- Start of processing for Validate_Compile_Time_Warning_Errors - - begin - Expander_Mode_Save_And_Set (False); - In_Compile_Time_Warning_Or_Error := True; - - for N in Compile_Time_Warnings_Errors.First .. - Compile_Time_Warnings_Errors.Last - loop - declare - T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N); - - begin - Set_Scope (T.Scope); - Reset_Analyzed_Flags (T.Prag); - Process_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc); - Unset_Scope (T.Scope); - end; - end loop; - - In_Compile_Time_Warning_Or_Error := False; - Expander_Mode_Restore; - end Validate_Compile_Time_Warning_Errors; - --------------------------- -- Validate_Independence -- --------------------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 3773a12..eb95e2b 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -189,18 +189,6 @@ package Sem_Ch13 is -- change. A False result is possible only for array, enumeration or -- record types. - procedure Validate_Compile_Time_Warning_Error (N : Node_Id); - -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean - -- expression is not known at compile time. This procedure makes an entry - -- in a table. The actual checking is performed by Validate_Compile_Time_ - -- Warning_Errors, which is invoked after calling the back end. - - procedure Validate_Compile_Time_Warning_Errors; - -- This routine is called after calling the back end to validate pragmas - -- Compile_Time_Error and Compile_Time_Warning for size and alignment - -- appropriateness. The reason it is called that late is to take advantage - -- of any back-annotation of size and alignment performed by the back end. - procedure Validate_Unchecked_Conversion (N : Node_Id; Act_Unit : Entity_Id); diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index 3b46ad5..378269f 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Einfo; use Einfo; with Namet; use Namet; with Opt; use Opt; with Restrict; use Restrict; @@ -83,7 +84,22 @@ package body Sem_Ch2 is procedure Analyze_Integer_Literal (N : Node_Id) is begin - Set_Etype (N, Universal_Integer); + -- As a lexical element, an integer literal has type Universal_Integer, + -- i.e., is compatible with any integer type. This is semantically + -- consistent and simplifies type checking and subsequent constant + -- folding when needed. An exception is caused by 64-bit modular types, + -- whose upper bound is not representable in a nonstatic context that + -- will use 64-bit integers at run time. For such cases, we need to + -- preserve the information that the analyzed literal has that modular + -- type. For simplicity, we preserve the information for all integer + -- literals that result from a modular operation. This happens after + -- prior analysis (or construction) of the literal, and after type + -- checking and resolution. + + if No (Etype (N)) or else not Is_Modular_Integer_Type (Etype (N)) then + Set_Etype (N, Universal_Integer); + end if; + Set_Is_Static_Expression (N); end Analyze_Integer_Literal; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 75a0099..645a024 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -221,9 +221,7 @@ package body Sem_Ch3 is -- T has discriminants but there are no discriminant constraints). The -- Related_Nod is the same as Decl_Node in Create_Constrained_Components. -- The For_Access says whether or not this subtype is really constraining - -- an access type. That is its sole purpose is the designated type of an - -- access type -- in which case a Private_Subtype Is_For_Access_Subtype - -- is built to avoid freezing T when the access subtype is frozen. + -- an access type. function Build_Scalar_Bound (Bound : Node_Id; @@ -930,17 +928,20 @@ package body Sem_Ch3 is -- declaration may include an expression that is an allocator, whose -- expansion needs the proper Master for the created tasks. - if Nkind (Related_Nod) = N_Object_Declaration and then Expander_Active + if Expander_Active + and then Nkind (Related_Nod) = N_Object_Declaration then if Is_Limited_Record (Desig_Type) and then Is_Class_Wide_Type (Desig_Type) + and then Tasking_Allowed then Build_Class_Wide_Master (Anon_Type); -- Similarly, if the type is an anonymous access that designates -- tasks, create a master entity for it in the current context. - elsif Has_Task (Desig_Type) and then Comes_From_Source (Related_Nod) + elsif Has_Task (Desig_Type) + and then Comes_From_Source (Related_Nod) then Build_Master_Entity (Defining_Identifier (Related_Nod)); Build_Master_Renaming (Anon_Type); @@ -3006,14 +3007,15 @@ package body Sem_Ch3 is -- is consistent with that of the parent. declare - Par_Discr : constant Entity_Id := - Get_Reference_Discriminant (Par_Type); - Cur_Discr : constant Entity_Id := + Cur_Discr : constant Entity_Id := Get_Reference_Discriminant (Prev); + Par_Discr : constant Entity_Id := + Get_Reference_Discriminant (Par_Type); begin if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then - Error_Msg_N ("aspect incosistent with that of parent", N); + Error_Msg_N + ("aspect inconsistent with that of parent", N); end if; -- Check that specification in partial view matches the @@ -3026,7 +3028,7 @@ package body Sem_Ch3 is Chars (Cur_Discr) then Error_Msg_N - ("aspect incosistent with that of parent", N); + ("aspect inconsistent with that of parent", N); end if; end; end if; @@ -3646,8 +3648,10 @@ package body Sem_Ch3 is -- Ghost mode. procedure Analyze_Object_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Id : constant Entity_Id := Defining_Identifier (N); + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + Next_Decl : constant Node_Id := Next (N); + Act_T : Entity_Id; T : Entity_Id; @@ -3909,6 +3913,11 @@ package body Sem_Ch3 is A_Id := Get_Aspect_Id (Chars (Identifier (A))); while Present (A) loop if A_Id = Aspect_Alignment or else A_Id = Aspect_Address then + + -- Set flag on object entity, for later processing at + -- the freeze point. + + Set_Has_Delayed_Aspects (Id); return True; end if; @@ -4492,8 +4501,20 @@ package body Sem_Ch3 is null; else - Insert_After (N, - Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc))); + -- The check must be inserted after the expanded aggregate + -- expansion code, if any. + + declare + Check : constant Node_Id := + Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)); + + begin + if No (Next_Decl) then + Append_To (List_Containing (N), Check); + else + Insert_Before (Next_Decl, Check); + end if; + end; end if; end if; @@ -4589,14 +4610,6 @@ package body Sem_Ch3 is elsif Is_Interface (T) then null; - -- In GNATprove mode, Expand_Subtype_From_Expr does nothing. Thus, - -- we should prevent the generation of another Itype with the - -- same name as the one already generated, or we end up with - -- two identical types in GNATprove. - - elsif GNATprove_Mode then - null; - -- If the type is an unchecked union, no subtype can be built from -- the expression. Rewrite declaration as a renaming, which the -- back-end can handle properly. This is a rather unusual case, @@ -10221,12 +10234,7 @@ package body Sem_Ch3 is begin if Ekind (T) = E_Record_Type then - if For_Access then - Set_Ekind (Def_Id, E_Private_Subtype); - Set_Is_For_Access_Subtype (Def_Id, True); - else - Set_Ekind (Def_Id, E_Record_Subtype); - end if; + Set_Ekind (Def_Id, E_Record_Subtype); -- Inherit preelaboration flag from base, for types for which it -- may have been set: records, private types, protected types. @@ -10357,7 +10365,7 @@ package body Sem_Ch3 is then Create_Constrained_Components (Def_Id, Related_Nod, T, Elist); - elsif not For_Access then + else Set_Cloned_Subtype (Def_Id, T); end if; end if; @@ -10627,9 +10635,9 @@ package body Sem_Ch3 is if Ekind (Contr_Typ) /= E_Protected_Type then Error_Msg_Node_2 := Contr_Typ; Error_Msg_NE - ("interface subprogram & cannot be implemented by a " & - "primitive procedure of task type &", Subp_Alias, - Iface_Alias); + ("interface subprogram & cannot be implemented by a " + & "primitive procedure of task type &", + Subp_Alias, Iface_Alias); -- An interface subprogram whose implementation kind is By_ -- Protected_Procedure must be implemented by a procedure. @@ -10637,28 +10645,27 @@ package body Sem_Ch3 is elsif Ekind (Impl_Subp) /= E_Procedure then Error_Msg_Node_2 := Iface_Alias; Error_Msg_NE - ("type & must implement abstract subprogram & with a " & - "procedure", Subp_Alias, Contr_Typ); + ("type & must implement abstract subprogram & with a " + & "procedure", Subp_Alias, Contr_Typ); elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) and then Implementation_Kind (Impl_Subp) /= Impl_Kind then Error_Msg_Name_1 := Impl_Kind; Error_Msg_N - ("overriding operation& must have synchronization%", - Subp_Alias); + ("overriding operation& must have synchronization%", + Subp_Alias); end if; -- If primitive has Optional synchronization, overriding operation - -- must match if it has an explicit synchronization.. + -- must match if it has an explicit synchronization. elsif Present (Get_Rep_Pragma (Impl_Subp, Name_Implemented)) and then Implementation_Kind (Impl_Subp) /= Impl_Kind then - Error_Msg_Name_1 := Impl_Kind; - Error_Msg_N - ("overriding operation& must have syncrhonization%", - Subp_Alias); + Error_Msg_Name_1 := Impl_Kind; + Error_Msg_N + ("overriding operation& must have synchronization%", Subp_Alias); end if; end Check_Pragma_Implemented; @@ -12337,48 +12344,73 @@ package body Sem_Ch3 is -- Next_Entity field of full to ensure that the calls to Copy_Node do -- not corrupt the entity chain. - -- Note that the type of the full view is the same entity as the type - -- of the partial view. In this fashion, the subtype has access to the - -- correct view of the parent. - -- The list below included access types, but this leads to several - -- regressions. How should the base type of the full view be - -- set consistently for subtypes completed by access types? - Save_Next_Entity := Next_Entity (Full); Save_Homonym := Homonym (Priv); - case Ekind (Full_Base) is - when Class_Wide_Kind - | Private_Kind - | Protected_Kind - | Task_Kind - | E_Record_Subtype - | E_Record_Type - => - Copy_Node (Priv, Full); + if Ekind (Full_Base) in Private_Kind + or else Ekind (Full_Base) in Protected_Kind + or else Ekind (Full_Base) in Record_Kind + or else Ekind (Full_Base) in Task_Kind + then + Copy_Node (Priv, Full); - Set_Has_Discriminants - (Full, Has_Discriminants (Full_Base)); - Set_Has_Unknown_Discriminants - (Full, Has_Unknown_Discriminants (Full_Base)); - Set_First_Entity (Full, First_Entity (Full_Base)); - Set_Last_Entity (Full, Last_Entity (Full_Base)); + -- Note that the Etype of the full view is the same as the Etype of + -- the partial view. In this fashion, the subtype has access to the + -- correct view of the parent. - -- If the underlying base type is constrained, we know that the - -- full view of the subtype is constrained as well (the converse - -- is not necessarily true). + Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); + Set_Has_Unknown_Discriminants + (Full, Has_Unknown_Discriminants (Full_Base)); + Set_First_Entity (Full, First_Entity (Full_Base)); + Set_Last_Entity (Full, Last_Entity (Full_Base)); - if Is_Constrained (Full_Base) then - Set_Is_Constrained (Full); - end if; + -- If the underlying base type is constrained, we know that the + -- full view of the subtype is constrained as well (the converse + -- is not necessarily true). - when others => - Copy_Node (Full_Base, Full); + if Is_Constrained (Full_Base) then + Set_Is_Constrained (Full); + end if; - Set_Chars (Full, Chars (Priv)); - Conditional_Delay (Full, Priv); - Set_Sloc (Full, Sloc (Priv)); - end case; + else + Copy_Node (Full_Base, Full); + + -- The following subtlety with the Etype of the full view needs to be + -- taken into account here. One could think that it must naturally be + -- set to the base type of the full base: + + -- Set_Etype (Full, Base_Type (Full_Base)); + + -- so that the full view becomes a subtype of the full base when the + -- latter is a base type, which must for example happen when the full + -- base is declared as derived type. That's also correct if the full + -- base is declared as an array type, or a floating-point type, or a + -- fixed-point type, or a signed integer type, as these declarations + -- create an implicit base type and a first subtype so the Etype of + -- the full views must be the implicit base type. But that's wrong + -- if the full base is declared as an access type, or an enumeration + -- type, or a modular integer type, as these declarations directly + -- create a base type, i.e. with Etype pointing to itself. Moreover + -- the full base being declared in the private part, i.e. when the + -- views are swapped, the end result is that the Etype of the full + -- base is set to its private view in this case and that we need to + -- propagate this setting to the full view in order for the subtype + -- to be compatible with the base type. + + if Is_Base_Type (Full_Base) + and then (Is_Derived_Type (Full_Base) + or else Ekind (Full_Base) in Array_Kind + or else Ekind (Full_Base) in Fixed_Point_Kind + or else Ekind (Full_Base) in Float_Kind + or else Ekind (Full_Base) in Signed_Integer_Kind) + then + Set_Etype (Full, Full_Base); + end if; + + Set_Chars (Full, Chars (Priv)); + Set_Sloc (Full, Sloc (Priv)); + Conditional_Delay (Full, Priv); + end if; Link_Entities (Full, Save_Next_Entity); Set_Homonym (Full, Save_Homonym); @@ -12386,35 +12418,14 @@ package body Sem_Ch3 is -- Set common attributes for all subtypes: kind, convention, etc. - Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); - Set_Convention (Full, Convention (Full_Base)); - - -- The Etype of the full view is inconsistent. Gigi needs to see the - -- structural full view, which is what the current scheme gives: the - -- Etype of the full view is the etype of the full base. However, if the - -- full base is a derived type, the full view then looks like a subtype - -- of the parent, not a subtype of the full base. If instead we write: - - -- Set_Etype (Full, Full_Base); - - -- then we get inconsistencies in the front-end (confusion between - -- views). Several outstanding bugs are related to this ??? - + Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base))); + Set_Convention (Full, Convention (Full_Base)); Set_Is_First_Subtype (Full, False); Set_Scope (Full, Scope (Priv)); Set_Size_Info (Full, Full_Base); Set_RM_Size (Full, RM_Size (Full_Base)); Set_Is_Itype (Full); - -- For the unusual case of a type with unknown discriminants whose - -- completion is an array, use the proper full base. - - if Is_Array_Type (Full_Base) - and then Has_Unknown_Discriminants (Priv) - then - Set_Etype (Full, Full_Base); - end if; - -- A subtype of a private-type-without-discriminants, whose full-view -- has discriminants with default expressions, is not constrained. @@ -12959,6 +12970,10 @@ package body Sem_Ch3 is if Desig_Type = Current_Scope and then No (Def_Id) then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_N ("<<constraint is ignored on component that is " + & "access to current record", S); + Set_Ekind (Desig_Subtype, E_Record_Subtype); Def_Id := Entity (Subtype_Mark (S)); @@ -17813,12 +17828,16 @@ package body Sem_Ch3 is Digs_Val : Uint; Base_Typ : Entity_Id; Implicit_Base : Entity_Id; - Bound : Node_Id; function Can_Derive_From (E : Entity_Id) return Boolean; -- Find if given digits value, and possibly a specified range, allows -- derivation from specified type + procedure Convert_Bound (B : Node_Id); + -- If specified, the bounds must be static but may be of different + -- types. They must be converted into machine numbers of the base type, + -- in accordance with RM 4.9(38). + function Find_Base_Type return Entity_Id; -- Find a predefined base type that Def can derive from, or generate -- an error and substitute Long_Long_Float if none exists. @@ -17856,6 +17875,28 @@ package body Sem_Ch3 is return True; end Can_Derive_From; + ------------------- + -- Convert_Bound -- + -------------------- + + procedure Convert_Bound (B : Node_Id) is + begin + -- If the bound is not a literal it can only be static if it is + -- a static constant, possibly of a specified type. + + if Is_Entity_Name (B) + and then Ekind (Entity (B)) = E_Constant + then + Rewrite (B, Constant_Value (Entity (B))); + end if; + + if Nkind (B) = N_Real_Literal then + Set_Realval (B, Machine (Base_Typ, Realval (B), Round, B)); + Set_Is_Machine_Number (B); + Set_Etype (B, Base_Typ); + end if; + end Convert_Bound; + -------------------- -- Find_Base_Type -- -------------------- @@ -17953,24 +17994,8 @@ package body Sem_Ch3 is Set_Scalar_Range (T, Real_Range_Specification (Def)); Set_Is_Constrained (T); - -- The bounds of this range must be converted to machine numbers - -- in accordance with RM 4.9(38). - - Bound := Type_Low_Bound (T); - - if Nkind (Bound) = N_Real_Literal then - Set_Realval - (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); - Set_Is_Machine_Number (Bound); - end if; - - Bound := Type_High_Bound (T); - - if Nkind (Bound) = N_Real_Literal then - Set_Realval - (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound)); - Set_Is_Machine_Number (Bound); - end if; + Convert_Bound (Type_Low_Bound (T)); + Convert_Bound (Type_High_Bound (T)); else Set_Scalar_Range (T, Scalar_Range (Base_Typ)); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3328f96..f7b99d4 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1699,7 +1699,7 @@ package body Sem_Ch4 is -- If the case expression is a formal object of mode in out, then -- treat it as having a nonstatic subtype by forcing use of the base - -- type (which has to get passed to Check_Case_Choices below). Also + -- type (which has to get passed to Check_Case_Choices below). Also -- use base type when the case expression is parenthesized. if Paren_Count (Expr) > 0 @@ -2101,21 +2101,12 @@ package body Sem_Ch4 is if not Is_Overloaded (P) then if Is_Access_Type (Etype (P)) then - -- Set the Etype. We need to go through Is_For_Access_Subtypes to - -- avoid other problems caused by the Private_Subtype and it is - -- safe to go to the Base_Type because this is the same as - -- converting the access value to its Base_Type. + -- Set the Etype declare - DT : Entity_Id := Designated_Type (Etype (P)); + DT : constant Entity_Id := Designated_Type (Etype (P)); begin - if Ekind (DT) = E_Private_Subtype - and then Is_For_Access_Subtype (DT) - then - DT := Base_Type (DT); - end if; - -- An explicit dereference is a legal occurrence of an -- incomplete type imported through a limited_with clause, if -- the full view is visible, or if we are within an instance @@ -6173,33 +6164,57 @@ package body Sem_Ch4 is if Nkind (N) = N_Function_Call then Get_First_Interp (Nam, X, It); - while Present (It.Nam) loop - if Ekind_In (It.Nam, E_Function, E_Operator) then - return; - else - Get_Next_Interp (X, It); - end if; - end loop; - -- If all interpretations are procedures, this deserves a - -- more precise message. Ditto if this appears as the prefix - -- of a selected component, which may be a lexical error. + if No (It.Typ) + and then Ekind (Entity (Name (N))) = E_Function + and then Present (Homonym (Entity (Name (N)))) + then + -- A name may appear overloaded if it has a homonym, even if that + -- homonym is non-overloadable, in which case the overload list is + -- in fact empty. This specialized case deserves a special message + -- if the homonym is a child package. - Error_Msg_N - ("\context requires function call, found procedure name", Nam); + declare + Nam : constant Node_Id := Name (N); + H : constant Entity_Id := Homonym (Entity (Nam)); - if Nkind (Parent (N)) = N_Selected_Component - and then N = Prefix (Parent (N)) - then - Error_Msg_N -- CODEFIX - ("\period should probably be semicolon", Parent (N)); + begin + if Ekind (H) = E_Package and then Is_Child_Unit (H) then + Error_Msg_Qual_Level := 2; + Error_Msg_NE ("if an entity in package& is meant, ", Nam, H); + Error_Msg_NE ("\use a fully qualified name", Nam, H); + Error_Msg_Qual_Level := 0; + end if; + end; + + else + while Present (It.Nam) loop + if Ekind_In (It.Nam, E_Function, E_Operator) then + return; + else + Get_Next_Interp (X, It); + end if; + end loop; + + -- If all interpretations are procedures, this deserves a more + -- precise message. Ditto if this appears as the prefix of a + -- selected component, which may be a lexical error. + + Error_Msg_N + ("\context requires function call, found procedure name", Nam); + + if Nkind (Parent (N)) = N_Selected_Component + and then N = Prefix (Parent (N)) + then + Error_Msg_N -- CODEFIX + ("\period should probably be semicolon", Parent (N)); + end if; end if; elsif Nkind (N) = N_Procedure_Call_Statement and then not Void_Interp_Seen then - Error_Msg_N ( - "\function name found in procedure call", Nam); + Error_Msg_N ("\function name found in procedure call", Nam); end if; All_Errors_Mode := Err_Mode; @@ -7806,7 +7821,7 @@ package body Sem_Ch4 is -- In_Parameter, but for now we examine the formal that -- corresponds to the indexing, and assume that variable -- indexing is required if some interpretation has an - -- assignable formal at that position. Still does not + -- assignable formal at that position. Still does not -- cover the most complex cases ??? if Is_Overloaded (Name (Parent (Par))) then diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 88fd204..ebe610b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2234,8 +2234,17 @@ package body Sem_Ch5 is It : Interp; begin + -- THe domain of iteralion must implement either the RM + -- iterator interface, or the SPARK Iterable aspect. + if No (Iterator) then - null; -- error reported below + if No + (Find_Aspect (Etype (Iter_Name), Aspect_Iterable)) + then + Error_Msg_NE ("cannot iterate over&", + N, Base_Type (Etype (Iter_Name))); + return; + end if; elsif not Is_Overloaded (Iterator) then Check_Reverse_Iteration (Etype (Iterator)); @@ -3080,7 +3089,7 @@ package body Sem_Ch5 is else -- A quantified expression that appears in a pre/post condition - -- is preanalyzed several times. If the range is given by an + -- is preanalyzed several times. If the range is given by an -- attribute reference it is rewritten as a range, and this is -- done even with expansion disabled. If the type is already set -- do not reanalyze, because a range with static bounds may be @@ -3904,7 +3913,7 @@ package body Sem_Ch5 is -- If the expander is not active then we want to analyze the loop body -- now even in the Ada 2012 iterator case, since the rewriting will not -- be done. Insert the loop variable in the current scope, if not done - -- when analysing the iteration scheme. Set its kind properly to detect + -- when analysing the iteration scheme. Set its kind properly to detect -- improper uses in the loop body. -- In GNATprove mode, we do one of the above depending on the kind of @@ -3998,7 +4007,7 @@ package body Sem_Ch5 is -- Variables referenced within a loop subject to possible OpenACC -- offloading may be implicitly written to as part of the OpenACC - -- transaction. Clear flags possibly conveying that they are constant, + -- transaction. Clear flags possibly conveying that they are constant, -- set for example when the code does not explicitly assign them. if Is_OpenAcc_Environment (Stmt) then @@ -4062,7 +4071,7 @@ package body Sem_Ch5 is end if; -- If we failed to find a label, it means the implicit declaration - -- of the label was hidden. A for-loop parameter can do this to + -- of the label was hidden. A for-loop parameter can do this to -- a label with the same name inside the loop, since the implicit -- label declaration is in the innermost enclosing body or block -- statement. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index cf1b0e7..25ee705 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3689,7 +3689,7 @@ package body Sem_Ch6 is -- generated. Freeze nodes, if any, are inserted before the current -- body. These freeze actions are also needed in ASIS mode and in -- Compile_Only mode to enable the proper back-end type annotations. - -- They are necessary in any case to insure order of elaboration + -- They are necessary in any case to ensure proper elaboration order -- in gigi. if Nkind (N) = N_Subprogram_Body @@ -3698,13 +3698,16 @@ package body Sem_Ch6 is and then Serious_Errors_Detected = 0 and then (Expander_Active or else ASIS_Mode - or else Operating_Mode = Check_Semantics) + or else Operating_Mode = Check_Semantics + or else Is_Ignored_Ghost_Entity (Spec_Id)) then -- The body generated for an expression function that is not a -- completion is a freeze point neither for the profile nor for -- anything else. That's why, in order to prevent any freezing -- during analysis, we need to mask types declared outside the -- expression (and in an outer scope) that are not yet frozen. + -- This also needs to be done in the case of an ignored Ghost + -- expression function, where the expander isn't active. Set_Is_Frozen (Spec_Id); Mask_Types := Mask_Unfrozen_Types (Spec_Id); @@ -5957,7 +5960,7 @@ package body Sem_Ch6 is Access_Definition (N, Discriminant_Type (New_Discr)); else - Analyze (Discriminant_Type (New_Discr)); + Find_Type (Discriminant_Type (New_Discr)); New_Discr_Type := Etype (Discriminant_Type (New_Discr)); -- Ada 2005: if the discriminant definition carries a null @@ -10152,7 +10155,7 @@ package body Sem_Ch6 is -- Here, S is "function ... return T;" declared in -- the private part, not overriding some visible - -- operation. That's illegal in the tagged case + -- operation. That's illegal in the tagged case -- (but not if the private type is untagged). if ((Present (Partial_View) @@ -11339,7 +11342,13 @@ package body Sem_Ch6 is goto Continue; end if; - Formal_Type := Entity (Ptype); + -- Protect against malformed parameter types + + if Nkind (Ptype) not in N_Has_Entity then + Formal_Type := Any_Type; + else + Formal_Type := Entity (Ptype); + end if; if Is_Incomplete_Type (Formal_Type) or else diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index 9e7f858..f069947 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -100,7 +100,7 @@ package Sem_Ch6 is Overridden_Subp : Entity_Id; Is_Primitive : Boolean); -- Verify the consistency of an overriding_indicator given for subprogram - -- declaration, body, renaming, or instantiation. Overridden_Subp is set + -- declaration, body, renaming, or instantiation. Overridden_Subp is set -- if the scope where we are introducing the subprogram contains a -- type-conformant subprogram that becomes hidden by the new subprogram. -- Is_Primitive indicates whether the subprogram is primitive. diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 6f5126e..e0d20ef 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -790,7 +790,7 @@ package body Sem_Ch7 is -- Deactivate expansion inside the body of ignored Ghost entities, -- as this code will ultimately be ignored. This avoids requiring the -- presence of run-time units which are not needed. Only do this for - -- user entities, as internally generated entitities might still need + -- user entities, as internally generated entities might still need -- to be expanded (e.g. those generated for types). if Present (Ignored_Ghost_Region) @@ -1063,7 +1063,7 @@ package body Sem_Ch7 is -- to the linker as their Is_Public flag is set to True. This proactive -- approach is necessary because an inlined or a generic body for which -- code is generated in other units may need to see these entities. Cut - -- down the number of global symbols that do not neet public visibility + -- down the number of global symbols that do not need public visibility -- as this has two beneficial effects: -- (1) It makes the compilation process more efficient. -- (2) It gives the code generator more leeway to optimize within each @@ -1757,7 +1757,7 @@ package body Sem_Ch7 is end if; -- There may be inherited private subprograms that need to be declared, - -- even in the absence of an explicit private part. If there are any + -- even in the absence of an explicit private part. If there are any -- public declarations in the package and the package is a public child -- unit, then an implicit private part is assumed. @@ -1883,7 +1883,7 @@ package body Sem_Ch7 is end if; -- Nested package specs that do not require bodies are not checked for - -- ineffective use clauses due to the possbility of subunits. This is + -- ineffective use clauses due to the possibility of subunits. This is -- because at this stage it is impossible to tell whether there will be -- a separate body. @@ -2261,7 +2261,7 @@ package body Sem_Ch7 is procedure Swap_Private_Dependents (Priv_Deps : Elist_Id); -- When the full view of a private type is made available, we do the -- same for its private dependents under proper visibility conditions. - -- When compiling a grand-chid unit this needs to be done recursively. + -- When compiling a grandchild unit this needs to be done recursively. ----------------------------- -- Swap_Private_Dependents -- @@ -3196,7 +3196,7 @@ package body Sem_Ch7 is E : Entity_Id; Requires_Body : Boolean := False; - -- Flag set when the unit has at least one construct that requries + -- Flag set when the unit has at least one construct that requires -- completion in a body. begin diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index b58ad64..7185c40 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -774,6 +774,10 @@ package body Sem_Ch8 is -- has already established its actual subtype. This is only relevant -- if the renamed object is an explicit dereference. + function Get_Object_Name (Nod : Node_Id) return Node_Id; + -- Obtain the name of the object from node Nod which is being renamed by + -- the object renaming declaration N. + ------------------------------ -- Check_Constrained_Object -- ------------------------------ @@ -802,17 +806,15 @@ package body Sem_Ch8 is null; -- If a record is limited its size is invariant. This is the case - -- in particular with record types with an access discirminant + -- in particular with record types with an access discriminant -- that are used in iterators. This is an optimization, but it -- also prevents typing anomalies when the prefix is further - -- expanded. Limited types with discriminants are included. + -- expanded. + -- Note that we cannot just use the Is_Limited_Record flag because + -- it does not apply to records with limited components, for which + -- this syntactic flag is not set, but whose size is also fixed. - elsif Is_Limited_Record (Typ) - or else - (Ekind (Typ) = E_Limited_Private_Type - and then Has_Discriminants (Typ) - and then Is_Access_Type (Etype (First_Discriminant (Typ)))) - then + elsif Is_Limited_Type (Typ) then null; else @@ -835,6 +837,33 @@ package body Sem_Ch8 is end if; end Check_Constrained_Object; + --------------------- + -- Get_Object_Name -- + --------------------- + + function Get_Object_Name (Nod : Node_Id) return Node_Id is + Obj_Nam : Node_Id; + + begin + Obj_Nam := Nod; + while Present (Obj_Nam) loop + if Nkind_In (Obj_Nam, N_Attribute_Reference, + N_Explicit_Dereference, + N_Indexed_Component, + N_Slice) + then + Obj_Nam := Prefix (Obj_Nam); + + elsif Nkind (Obj_Nam) = N_Selected_Component then + Obj_Nam := Selector_Name (Obj_Nam); + else + exit; + end if; + end loop; + + return Obj_Nam; + end Get_Object_Name; + -- Start of processing for Analyze_Object_Renaming begin @@ -1151,18 +1180,10 @@ package body Sem_Ch8 is elsif Ada_Version >= Ada_2005 and then Nkind (Nam) in N_Has_Entity then declare - Nam_Decl : Node_Id; - Nam_Ent : Entity_Id; + Nam_Ent : constant Entity_Id := Entity (Get_Object_Name (Nam)); + Nam_Decl : constant Node_Id := Declaration_Node (Nam_Ent); begin - if Nkind (Nam) = N_Attribute_Reference then - Nam_Ent := Entity (Prefix (Nam)); - else - Nam_Ent := Entity (Nam); - end if; - - Nam_Decl := Parent (Nam_Ent); - if Has_Null_Exclusion (N) and then not Has_Null_Exclusion (Nam_Decl) then @@ -4815,6 +4836,13 @@ package body Sem_Ch8 is Set_In_Use (Base_Type (T), False); Set_Current_Use_Clause (T, Empty); Set_Current_Use_Clause (Base_Type (T), Empty); + + -- See Use_One_Type for the rationale. This is a bit on the naive + -- side, but should be good enough in practice. + + if Is_Tagged_Type (T) then + Set_In_Use (Class_Wide_Type (T), False); + end if; end if; end if; @@ -8733,7 +8761,7 @@ package body Sem_Ch8 is if Scope_Stack.Last > Scope_Stack.First then SST.Component_Alignment_Default := Scope_Stack.Table - (Scope_Stack.Last - 1). Component_Alignment_Default; + (Scope_Stack.Last - 1).Component_Alignment_Default; -- Otherwise, this is the first scope being pushed on the scope -- stack. Inherit the component alignment from the configuration @@ -9964,7 +9992,10 @@ package body Sem_Ch8 is Set_In_Use (T); -- If T is tagged, primitive operators on class-wide operands are - -- also available. + -- also deemed available. Note that this is really necessary only + -- in semantics-only mode, because the primitive operators are not + -- fully constructed in this mode, but we do it in all modes for the + -- sake of uniformity, as this should not matter in practice. if Is_Tagged_Type (T) then Set_In_Use (Class_Wide_Type (T)); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index a71c35c..0696f92 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -883,7 +883,13 @@ package body Sem_Ch9 is exit when Task_Nam = Scope_Stack.Table (J).Entity; if Entry_Nam = Scope_Stack.Table (J).Entity then - Error_Msg_N ("duplicate accept statement for same entry", N); + Error_Msg_N + ("duplicate accept statement for same entry (RM 9.5.2 (15))", N); + + -- Do not continue analysis of accept statement, to prevent + -- cascaded errors. + + return; end if; end loop; @@ -1891,9 +1897,6 @@ package body Sem_Ch9 is ---------------------------------- procedure Analyze_Protected_Definition (N : Node_Id) is - E : Entity_Id; - L : Entity_Id; - procedure Undelay_Itypes (T : Entity_Id); -- Itypes created for the private components of a protected type -- do not receive freeze nodes, because there is no scope in which @@ -1926,9 +1929,7 @@ package body Sem_Ch9 is end if; while Present (Comp) loop - if Is_Type (Comp) - and then Is_Itype (Comp) - then + if Is_Type (Comp) and then Is_Itype (Comp) then Set_Has_Delayed_Freeze (Comp, False); Set_Is_Frozen (Comp); @@ -1936,9 +1937,7 @@ package body Sem_Ch9 is Layout_Type (Comp); end if; - if Is_Record_Type (Comp) - or else Is_Protected_Type (Comp) - then + if Is_Record_Type (Comp) or else Is_Protected_Type (Comp) then Undelay_Itypes (Comp); end if; end if; @@ -1947,6 +1946,12 @@ package body Sem_Ch9 is end loop; end Undelay_Itypes; + -- Local variables + + Prot_Typ : constant Entity_Id := Current_Scope; + Item_Id : Entity_Id; + Last_Id : Entity_Id; + -- Start of processing for Analyze_Protected_Definition begin @@ -1957,32 +1962,37 @@ package body Sem_Ch9 is if Present (Private_Declarations (N)) and then not Is_Empty_List (Private_Declarations (N)) then - L := Last_Entity (Current_Scope); + Last_Id := Last_Entity (Prot_Typ); Analyze_Declarations (Private_Declarations (N)); - if Present (L) then - Set_First_Private_Entity (Current_Scope, Next_Entity (L)); + if Present (Last_Id) then + Set_First_Private_Entity (Prot_Typ, Next_Entity (Last_Id)); else - Set_First_Private_Entity (Current_Scope, - First_Entity (Current_Scope)); + Set_First_Private_Entity (Prot_Typ, First_Entity (Prot_Typ)); end if; end if; - E := First_Entity (Current_Scope); - while Present (E) loop - if Ekind_In (E, E_Function, E_Procedure) then - Set_Convention (E, Convention_Protected); + Item_Id := First_Entity (Prot_Typ); + while Present (Item_Id) loop + if Ekind_In (Item_Id, E_Function, E_Procedure) then + Set_Convention (Item_Id, Convention_Protected); else - Propagate_Concurrent_Flags (Current_Scope, Etype (E)); + Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id)); + + if Chars (Item_Id) /= Name_uParent + and then Needs_Finalization (Etype (Item_Id)) + then + Set_Has_Controlled_Component (Prot_Typ); + end if; end if; - Next_Entity (E); + Next_Entity (Item_Id); end loop; - Undelay_Itypes (Current_Scope); + Undelay_Itypes (Prot_Typ); Check_Max_Entries (N, Max_Protected_Entries); - Process_End_Label (N, 'e', Current_Scope); + Process_End_Label (N, 'e', Prot_Typ); end Analyze_Protected_Definition; ---------------------------------------- diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 43b1f23..2bcccd2 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -115,7 +115,7 @@ package body Sem_Dim is type Symbol_Array is array (Dimension_Position range - Low_Position_Bound .. High_Position_Bound) of String_Id; + Low_Position_Bound .. High_Position_Bound) of String_Id; -- Store the symbols of all units within a system No_Symbols : constant Symbol_Array := (others => No_String); @@ -151,7 +151,7 @@ package body Sem_Dim is type Dimension_Type is array (Dimension_Position range - Low_Position_Bound .. High_Position_Bound) of Rational; + Low_Position_Bound .. High_Position_Bound) of Rational; Null_Dimension : constant Dimension_Type := (others => Zero); @@ -399,9 +399,9 @@ package body Sem_Dim is function "+" (Left, Right : Rational) return Rational is R : constant Rational := - Rational'(Numerator => Left.Numerator * Right.Denominator + - Left.Denominator * Right.Numerator, - Denominator => Left.Denominator * Right.Denominator); + Rational'(Numerator => Left.Numerator * Right.Denominator + + Left.Denominator * Right.Numerator, + Denominator => Left.Denominator * Right.Denominator); begin return Reduce (R); end "+"; @@ -1233,8 +1233,9 @@ package body Sem_Dim is Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ); Exps : constant List_Id := Expressions (N); - Comp : Node_Id; - Expr : Node_Id; + Comp : Node_Id; + Dims_Of_Expr : Dimension_Type; + Expr : Node_Id; Error_Detected : Boolean := False; -- This flag is used in order to indicate if an error has been detected @@ -1281,11 +1282,19 @@ package body Sem_Dim is -- (may happen when an aggregate is converted into a positional -- aggregate). We also must verify that this is a scalar component, -- and not a subaggregate of a multidimensional aggregate. + -- The expression may be an identifier that has been copied several + -- times during expansion, its dimensions are those of its type. + + if Is_Entity_Name (Expr) then + Dims_Of_Expr := Dimensions_Of (Etype (Expr)); + else + Dims_Of_Expr := Dimensions_Of (Expr); + end if; if Comes_From_Source (Original_Node (Expr)) and then Present (Etype (Expr)) and then Is_Numeric_Type (Etype (Expr)) - and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ + and then Dims_Of_Expr /= Dims_Of_Comp_Typ and then Sloc (Comp) /= Sloc (Prev (Comp)) then -- Check if an error has already been encountered so far @@ -2897,7 +2906,7 @@ package body Sem_Dim is New_Aspects := Empty_List; List_Of_Dims := New_List; - for Position in Dims_Of_N'First .. System.Count loop + for Position in Dims_Of_N'First .. System.Count loop Dim_Power := Dims_Of_N (Position); Append_To (List_Of_Dims, Make_Op_Divide (Loc, @@ -3014,7 +3023,7 @@ package body Sem_Dim is -- System.Dim.Float_IO or System.Dim.Integer_IO, the default string -- parameter is rewritten to include the unit symbol (or the dimension -- symbols if not a defined quantity) in the output of a dimensioned - -- object. If a value is already supplied by the user for the parameter + -- object. If a value is already supplied by the user for the parameter -- Symbol, it is used as is. -- Case 1. Item is dimensionless diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index a2f753b..5deba18 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -211,6 +211,15 @@ package body Sem_Disp is if Present (Ctrl_Type) then + -- Obtain the full type in case we are looking at an incomplete + -- view. + + if Ekind (Ctrl_Type) = E_Incomplete_Type + and then Present (Full_View (Ctrl_Type)) + then + Ctrl_Type := Full_View (Ctrl_Type); + end if; + -- When controlling type is concurrent and declared within a -- generic or inside an instance use corresponding record type. @@ -587,7 +596,7 @@ package body Sem_Disp is -- We need to determine whether the context of the call -- provides a tag to make the call dispatching. This requires -- the call to be the actual in an enclosing call, and that - -- actual must be controlling. If the call is an operand of + -- actual must be controlling. If the call is an operand of -- equality, the other operand must not ve abstract. if not Is_Tagged_Type (Typ) diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index f57b3b1..3145559 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -496,12 +496,6 @@ package body Sem_Elab is -- actual subprograms through generic formal subprograms. As a -- result, the calls are not recorded or processed. -- - -- -gnatd_G encode invocation graph in ALI files - -- - -- The ABE mechanism encodes the invocation graph of the main - -- unit. This includes elaboration code, as well as invocation - -- constructs. - -- -- -gnatd_i ignore activations and calls to instances for elaboration -- -- The ABE mechanism ignores calls and task activations when they @@ -676,6 +670,22 @@ package body Sem_Elab is -- Kinds -- ----------- + -- The following type enumerates all possible elaboration phase statutes + + type Elaboration_Phase_Status is + (Inactive, + -- The elaboration phase of the compiler has not started yet + + Active, + -- The elaboration phase of the compiler is currently in progress + + Completed); + -- The elaboration phase of the compiler has finished + + Elaboration_Phase : Elaboration_Phase_Status := Inactive; + -- The status of the elaboration phase. Use routine Set_Elaboration_Phase + -- to alter its value. + -- The following type enumerates all subprogram body traversal modes type Body_Traversal_Kind is @@ -772,6 +782,9 @@ package body Sem_Elab is (Generic_Target, -- A generic unit being instantiated + Package_Target, + -- The package form of an instantiation + Subprogram_Target, -- An entry, operator, or subprogram being invoked, or aliased through -- 'Access or 'Unrestricted_Access. @@ -1958,6 +1971,14 @@ package body Sem_Elab is -- Return the type of subprogram Subp_Id's first formal parameter. If the -- subprogram lacks formal parameters, return Empty. + function Elaboration_Phase_Active return Boolean; + pragma Inline (Elaboration_Phase_Active); + -- Determine whether the elaboration phase of the compilation has started + + procedure Finalize_All_Data_Structures; + pragma Inline (Finalize_All_Data_Structures); + -- Destroy all internal data structures + function Has_Body (Pack_Decl : Node_Id) return Boolean; pragma Inline (Has_Body); -- Determine whether package declaration Pack_Decl has a corresponding body @@ -1984,6 +2005,10 @@ package body Sem_Elab is -- context ignoring enclosing library levels. Nested_OK should be set when -- the context of N1 can enclose that of N2. + procedure Initialize_All_Data_Structures; + pragma Inline (Initialize_All_Data_Structures); + -- Create all internal data structures + function Instantiated_Generic (Inst : Node_Id) return Entity_Id; pragma Inline (Instantiated_Generic); -- Obtain the generic instantiated by instance Inst @@ -2018,6 +2043,10 @@ package body Sem_Elab is pragma Inline (Is_Same_Unit); -- Determine whether entities Unit_1 and Unit_2 denote the same unit + function Main_Unit_Entity return Entity_Id; + pragma Inline (Main_Unit_Entity); + -- Return the entity of the main unit + function Non_Private_View (Typ : Entity_Id) return Entity_Id; pragma Inline (Non_Private_View); -- Return the full view of private type Typ if available, otherwise return @@ -2027,6 +2056,10 @@ package body Sem_Elab is pragma Inline (Scenario); -- Return the appropriate scenario node for scenario N + procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status); + pragma Inline (Set_Elaboration_Phase); + -- Change the status of the elaboration phase of the compiler to Status + procedure Spec_And_Body_From_Entity (Id : Node_Id; Spec_Decl : out Node_Id; @@ -3572,6 +3605,12 @@ package body Sem_Elab is elsif Preanalysis_Active then return; + -- Nothing to do when the elaboration phase of the compiler is not + -- active. + + elsif not Elaboration_Phase_Active then + return; + -- Nothing to do when the input does not denote a call or a requeue elsif not Nkind_In (N, N_Entry_Call_Statement, @@ -3789,6 +3828,13 @@ package body Sem_Elab is -- Start of processing for Build_Variable_Reference_Marker begin + -- Nothing to do when the elaboration phase of the compiler is not + -- active. + + if not Elaboration_Phase_Active then + return; + end if; + Marker := Make_Variable_Reference_Marker (Sloc (N)); -- Inherit the attributes of the original variable reference @@ -3887,30 +3933,30 @@ package body Sem_Elab is -- to carry out this action. if Legacy_Elaboration_Checks then + Finalize_All_Data_Structures; return; -- Nothing to do for ASIS because ABE checks and diagnostics are not -- performed in this mode. elsif ASIS_Mode then + Finalize_All_Data_Structures; return; - end if; - -- Create all internal data structures + -- Nothing to do when the elaboration phase of the compiler is not + -- active. - Initialize_Body_Processor; - Initialize_Early_Call_Region_Processor; - Initialize_Elaborated_Units; - Initialize_Internal_Representation; - Initialize_Invocation_Graph; - Initialize_Scenario_Storage; + elsif not Elaboration_Phase_Active then + Finalize_All_Data_Structures; + return; + end if; -- Restore the original elaboration model which was in effect when the -- scenarios were first recorded. The model may be specified by pragma -- Elaboration_Checks which appears on the initial declaration of the -- main unit. - Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit))); + Install_Elaboration_Model (Unit_Entity (Main_Unit_Entity)); -- Examine the context of the main unit and record all units with prior -- elaboration with respect to it. @@ -3949,14 +3995,11 @@ package body Sem_Elab is Record_Invocation_Graph; - -- Destroy all internal data structures + -- Destroy all internal data structures and complete the elaboration + -- phase of the compiler. - Finalize_Body_Processor; - Finalize_Early_Call_Region_Processor; - Finalize_Elaborated_Units; - Finalize_Internal_Representation; - Finalize_Invocation_Graph; - Finalize_Scenario_Storage; + Finalize_All_Data_Structures; + Set_Elaboration_Phase (Completed); end Check_Elaboration_Scenarios; --------------------- @@ -6302,7 +6345,7 @@ package body Sem_Elab is -- because diagnostics on reads are relevant only for external -- variables. - if Is_Same_Unit (Unit_Id, Cunit_Entity (Main_Unit)) then + if Is_Same_Unit (Unit_Id, Main_Unit_Entity) then null; -- Nothing to do when the variable is already initialized. Note that @@ -7676,8 +7719,7 @@ package body Sem_Elab is -- The following map relates an elaboration attributes of a unit to the -- unit. - Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := - UA_Map.Create (250); + Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := UA_Map.Nil; ------------------ -- Constructors -- @@ -8122,7 +8164,7 @@ package body Sem_Elab is -- body of A elaborated <-- problem -- -- The generation of an implicit pragma Elaborate_All (B) ensures - -- that the elaboration order mechanism will not pick the above + -- that the elaboration-order mechanism will not pick the above -- order. -- -- An implicit Elaborate is NOT generated when the unit is subject @@ -8461,10 +8503,9 @@ package body Sem_Elab is Elab_Body_OK : Boolean := False; Same_Unit_OK : Boolean := False) return Boolean is - EA_Id : constant Elaboration_Attributes_Id := - Elaboration_Attributes_Of (Unit_Id); - - Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + EA_Id : constant Elaboration_Attributes_Id := + Elaboration_Attributes_Of (Unit_Id); + Main_Id : constant Entity_Id := Main_Unit_Entity; Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id); Unit_With : constant Node_Id := With_Clause (EA_Id); @@ -8519,7 +8560,7 @@ package body Sem_Elab is procedure Initialize_Elaborated_Units is begin - null; + Unit_To_Attributes_Map := UA_Map.Create (250); end Initialize_Elaborated_Units; ---------------------------------- @@ -8534,7 +8575,7 @@ package body Sem_Elab is is pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All)); - Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + Main_Id : constant Entity_Id := Main_Unit_Entity; Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id); procedure Elaboration_Requirement_Error; @@ -8800,6 +8841,29 @@ package body Sem_Elab is end With_Clause; end Elaborated_Units; + ------------------------------ + -- Elaboration_Phase_Active -- + ------------------------------ + + function Elaboration_Phase_Active return Boolean is + begin + return Elaboration_Phase = Active; + end Elaboration_Phase_Active; + + ---------------------------------- + -- Finalize_All_Data_Structures -- + ---------------------------------- + + procedure Finalize_All_Data_Structures is + begin + Finalize_Body_Processor; + Finalize_Early_Call_Region_Processor; + Finalize_Elaborated_Units; + Finalize_Internal_Representation; + Finalize_Invocation_Graph; + Finalize_Scenario_Storage; + end Finalize_All_Data_Structures; + ----------------------------- -- Find_Enclosing_Instance -- ----------------------------- @@ -10072,8 +10136,28 @@ package body Sem_Elab is -- each time it is transformed into another node. Set_Rewriting_Proc (Update_Elaboration_Scenario'Access); + + -- Create all internal data structures and activate the elaboration + -- phase of the compiler. + + Initialize_All_Data_Structures; + Set_Elaboration_Phase (Active); end Initialize; + ------------------------------------ + -- Initialize_All_Data_Structures -- + ------------------------------------ + + procedure Initialize_All_Data_Structures is + begin + Initialize_Body_Processor; + Initialize_Early_Call_Region_Processor; + Initialize_Elaborated_Units; + Initialize_Internal_Representation; + Initialize_Invocation_Graph; + Initialize_Scenario_Storage; + end Initialize_All_Data_Structures; + -------------------------- -- Instantiated_Generic -- -------------------------- @@ -10201,8 +10285,7 @@ package body Sem_Elab is -- The following map relates target representations to entities - Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := - ETT_Map.Create (500); + Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := ETT_Map.Nil; procedure Destroy (S_Id : in out Scenario_Rep_Id); -- Destroy a scenario representation S_Id @@ -10221,8 +10304,7 @@ package body Sem_Elab is -- The following map relates scenario representations to nodes - Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := - NTS_Map.Create (500); + Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := NTS_Map.Nil; -- The following table stores all scenario representations @@ -10274,6 +10356,11 @@ package body Sem_Elab is pragma Inline (Create_Instantiation_Rep); -- Create the representation of instantiation Inst + function Create_Package_Rep + (Pack_Id : Entity_Id) return Target_Rep_Record; + pragma Inline (Create_Package_Rep); + -- Create the representation of package Pack_Id + function Create_Protected_Entry_Rep (PE_Id : Entity_Id) return Target_Rep_Record; pragma Inline (Create_Protected_Entry_Rep); @@ -10542,6 +10629,26 @@ package body Sem_Elab is return Rec; end Create_Instantiation_Rep; + ------------------------ + -- Create_Package_Rep -- + ------------------------ + + function Create_Package_Rep + (Pack_Id : Entity_Id) return Target_Rep_Record + is + Rec : Target_Rep_Record; + + begin + Rec.Kind := Package_Target; + + Spec_And_Body_From_Entity + (Id => Pack_Id, + Body_Decl => Rec.Body_Decl, + Spec_Decl => Rec.Spec_Decl); + + return Rec; + end Create_Package_Rep; + -------------------------------- -- Create_Protected_Entry_Rep -- -------------------------------- @@ -10764,6 +10871,9 @@ package body Sem_Elab is then Rec := Create_Subprogram_Rep (Id); + elsif Ekind (Id) = E_Package then + Rec := Create_Package_Rep (Id); + else pragma Assert (False); return Rec; @@ -11058,7 +11168,8 @@ package body Sem_Elab is procedure Initialize_Internal_Representation is begin - null; + Entity_To_Target_Map := ETT_Map.Create (500); + Node_To_Scenario_Map := NTS_Map.Create (500); end Initialize_Internal_Representation; ------------------------- @@ -11539,6 +11650,14 @@ package body Sem_Elab is -- Process invocation call scenario Call with representation Call_Rep. -- In_State is the current state of the Processing phase. + procedure Process_Invocation_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State); + pragma Inline (Process_Invocation_Instantiation); + -- Process invocation instantiation scenario Inst with representation + -- Inst_Rep. In_State is the current state of the Processing phase. + procedure Process_Invocation_Scenario (N : Node_Id; In_State : Processing_In_State); @@ -11606,6 +11725,11 @@ package body Sem_Elab is -- active scenarios. In_State is the current state of the Processing -- phase. + procedure Record_Invocation_Graph_Encoding; + pragma Inline (Record_Invocation_Graph_Encoding); + -- Record the encoding format used to capture information related to + -- invocation constructs and relations. + procedure Record_Invocation_Path (In_State : Processing_In_State); pragma Inline (Record_Invocation_Path); -- Record the invocation relations found within the path represented in @@ -11679,7 +11803,7 @@ package body Sem_Elab is end if; Spec_And_Body_From_Entity - (Id => Cunit_Entity (Main_Unit), + (Id => Main_Unit_Entity, Body_Decl => Body_Decl, Spec_Decl => Spec_Decl); @@ -11711,7 +11835,7 @@ package body Sem_Elab is Set_Ekind (Proc_Id, E_Procedure); Set_Etype (Proc_Id, Standard_Void_Type); - Set_Scope (Proc_Id, Unique_Entity (Cunit_Entity (Main_Unit))); + Set_Scope (Proc_Id, Unique_Entity (Main_Unit_Entity)); -- Create a dummy declaration for the elaboration procedure. The -- declaration does not need to be syntactically legal, but must @@ -11742,7 +11866,7 @@ package body Sem_Elab is end if; Spec_And_Body_From_Entity - (Id => Cunit_Entity (Main_Unit), + (Id => Main_Unit_Entity, Body_Decl => Body_Decl, Spec_Decl => Spec_Decl); @@ -11855,40 +11979,32 @@ package body Sem_Elab is (Constr_Id : Entity_Id; In_State : Processing_In_State) is + function Body_Placement_Of + (Id : Entity_Id) return Declaration_Placement_Kind; + pragma Inline (Body_Placement_Of); + -- Obtain the placement of arbitrary entity Id's body + + function Declaration_Placement_Of_Node + (N : Node_Id) return Declaration_Placement_Kind; + pragma Inline (Declaration_Placement_Of_Node); + -- Obtain the placement of arbitrary node N + function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind; pragma Inline (Kind_Of); -- Obtain the invocation construct kind of arbitrary entity Id - function Placement_Of (Id : Entity_Id) return Body_Placement_Kind; - pragma Inline (Placement_Of); - -- Obtain the body placement of arbitrary entity Id - - function Placement_Of_Node (N : Node_Id) return Body_Placement_Kind; - pragma Inline (Placement_Of_Node); - -- Obtain the body placement of arbitrary node N - - ------------- - -- Kind_Of -- - ------------- + function Spec_Placement_Of + (Id : Entity_Id) return Declaration_Placement_Kind; + pragma Inline (Spec_Placement_Of); + -- Obtain the placement of arbitrary entity Id's spec - function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is - begin - if Id = Elab_Body_Id then - return Elaborate_Body_Procedure; - - elsif Id = Elab_Spec_Id then - return Elaborate_Spec_Procedure; - - else - return Regular_Construct; - end if; - end Kind_Of; - - ------------------ - -- Placement_Of -- - ------------------ + ----------------------- + -- Body_Placement_Of -- + ----------------------- - function Placement_Of (Id : Entity_Id) return Body_Placement_Kind is + function Body_Placement_Of + (Id : Entity_Id) return Declaration_Placement_Kind + is Id_Rep : constant Target_Rep_Id := Target_Representation_Of (Id, In_State); Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); @@ -11898,22 +12014,24 @@ package body Sem_Elab is -- The entity has a body if Present (Body_Decl) then - return Placement_Of_Node (Body_Decl); + return Declaration_Placement_Of_Node (Body_Decl); -- Otherwise the entity must have a spec else pragma Assert (Present (Spec_Decl)); - return Placement_Of_Node (Spec_Decl); + return Declaration_Placement_Of_Node (Spec_Decl); end if; - end Placement_Of; + end Body_Placement_Of; - ----------------------- - -- Placement_Of_Node -- - ----------------------- + ----------------------------------- + -- Declaration_Placement_Of_Node -- + ----------------------------------- - function Placement_Of_Node (N : Node_Id) return Body_Placement_Kind is - Main_Unit_Id : constant Entity_Id := Cunit_Entity (Main_Unit); + function Declaration_Placement_Of_Node + (N : Node_Id) return Declaration_Placement_Kind + is + Main_Unit_Id : constant Entity_Id := Main_Unit_Entity; N_Unit_Id : constant Entity_Id := Find_Top_Unit (N); begin @@ -11956,11 +12074,50 @@ package body Sem_Elab is else return In_Body; end if; - end Placement_Of_Node; + end Declaration_Placement_Of_Node; - -- Local variables + ------------- + -- Kind_Of -- + ------------- + + function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is + begin + if Id = Elab_Body_Id then + return Elaborate_Body_Procedure; + + elsif Id = Elab_Spec_Id then + return Elaborate_Spec_Procedure; + + else + return Regular_Construct; + end if; + end Kind_Of; + + ----------------------- + -- Spec_Placement_Of -- + ----------------------- + + function Spec_Placement_Of + (Id : Entity_Id) return Declaration_Placement_Kind + is + Id_Rep : constant Target_Rep_Id := + Target_Representation_Of (Id, In_State); + Body_Decl : constant Node_Id := Body_Declaration (Id_Rep); + Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep); + + begin + -- The entity has a spec + + if Present (Spec_Decl) then + return Declaration_Placement_Of_Node (Spec_Decl); - IC_Rec : Invocation_Construct_Record; + -- Otherwise the entity must have a body + + else + pragma Assert (Present (Body_Decl)); + return Declaration_Placement_Of_Node (Body_Decl); + end if; + end Spec_Placement_Of; -- Start of processing for Declare_Invocation_Construct @@ -11976,15 +12133,14 @@ package body Sem_Elab is Set_Is_Saved_Construct (Constr_Id); - IC_Rec.Kind := Kind_Of (Constr_Id); - IC_Rec.Placement := Placement_Of (Constr_Id); - IC_Rec.Signature := Signature_Of (Constr_Id); - -- Add the construct in the ALI file Add_Invocation_Construct - (IC_Rec => IC_Rec, - Update_Units => False); + (Body_Placement => Body_Placement_Of (Constr_Id), + Kind => Kind_Of (Constr_Id), + Signature => Signature_Of (Constr_Id), + Spec_Placement => Spec_Placement_Of (Constr_Id), + Update_Units => False); end Declare_Invocation_Construct; ------------------------------- @@ -12030,16 +12186,10 @@ package body Sem_Elab is Main_Cunit : constant Node_Id := Cunit (Main_Unit); begin - -- Nothing to do when switch -gnatd_G (encode invocation graph in ALI - -- files) is not in effect. - - if not Debug_Flag_Underscore_GG then - return False; - -- Nothing to do when compiling for GNATprove because the invocation -- graph is not needed. - elsif GNATprove_Mode then + if GNATprove_Mode then return False; -- Nothing to do when the compilation will not produce an ALI file @@ -12338,6 +12488,43 @@ package body Sem_Elab is end if; end Process_Invocation_Call; + -------------------------------------- + -- Process_Invocation_Instantiation -- + -------------------------------------- + + procedure Process_Invocation_Instantiation + (Inst : Node_Id; + Inst_Rep : Scenario_Rep_Id; + In_State : Processing_In_State) + is + pragma Unreferenced (Inst); + + Gen_Id : constant Entity_Id := Target (Inst_Rep); + + begin + -- Nothing to do when the generic appears within an internal unit + + if In_Internal_Unit (Gen_Id) then + return; + end if; + + -- The generic being instantiated resides within an external unit + -- + -- Main unit External unit + -- +-----------+ +-------------+ + -- | | | | + -- | Start ------------> Generic | + -- | | | | + -- +-----------+ +-------------+ + -- + -- Record the invocation path which originates from Start and reaches + -- the generic. + + if not In_Extended_Main_Code_Unit (Gen_Id) then + Record_Invocation_Path (In_State); + end if; + end Process_Invocation_Instantiation; + --------------------------------- -- Process_Invocation_Scenario -- --------------------------------- @@ -12383,6 +12570,14 @@ package body Sem_Elab is In_State => In_State); end if; end if; + + -- Instantiation + + elsif Is_Suitable_Instantiation (Scen) then + Process_Invocation_Instantiation + (Inst => Scen, + Inst_Rep => Scenario_Representation_Of (Scen, In_State), + In_State => In_State); end if; -- Remove the current scenario from the stack of active scenarios @@ -12726,6 +12921,12 @@ package body Sem_Elab is return; end if; + -- Save the encoding format used to capture information about the + -- invocation constructs and relations in the ALI file of the main + -- unit. + + Record_Invocation_Graph_Encoding; + -- Examine all library level invocation scenarios and perform DFS -- traversals from each one. Encode a path in the ALI file of the -- main unit if it reaches into an external unit. @@ -12741,6 +12942,30 @@ package body Sem_Elab is Process_Main_Unit; end Record_Invocation_Graph; + -------------------------------------- + -- Record_Invocation_Graph_Encoding -- + -------------------------------------- + + procedure Record_Invocation_Graph_Encoding is + Kind : Invocation_Graph_Encoding_Kind := No_Encoding; + + begin + -- Switch -gnatd_F (encode full invocation paths in ALI files) is in + -- effect. + + if Debug_Flag_Underscore_FF then + Kind := Full_Path_Encoding; + else + Kind := Endpoints_Encoding; + end if; + + -- Save the encoding format in the ALI file of the main unit + + Set_Invocation_Graph_Encoding + (Kind => Kind, + Update_Units => False); + end Record_Invocation_Graph_Encoding; + ---------------------------- -- Record_Invocation_Path -- ---------------------------- @@ -12799,6 +13024,10 @@ package body Sem_Elab is (Extra : out Entity_Id; Kind : out Invocation_Kind) is + Targ_Rep : constant Target_Rep_Id := + Target_Representation_Of (Targ_Id, In_State); + Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); + begin -- Accept within a task body @@ -12887,7 +13116,7 @@ package body Sem_Elab is -- Postcondition verification elsif Is_Postconditions_Proc (Targ_Id) then - Extra := Find_Enclosing_Scope (Targ_Id); + Extra := Find_Enclosing_Scope (Spec_Decl); Kind := Postcondition_Verification; -- Protected entry call @@ -12930,7 +13159,6 @@ package body Sem_Elab is Extra : Entity_Id; Extra_Nam : Name_Id; - IR_Rec : Invocation_Relation_Record; Kind : Invocation_Kind; Rel : Invoker_Target_Relation; @@ -12969,15 +13197,13 @@ package body Sem_Elab is Extra_Nam := No_Name; end if; - IR_Rec.Extra := Extra_Nam; - IR_Rec.Invoker := Signature_Of (Invk_Id); - IR_Rec.Kind := Kind; - IR_Rec.Target := Signature_Of (Targ_Id); - -- Add the relation in the ALI file Add_Invocation_Relation - (IR_Rec => IR_Rec, + (Extra => Extra_Nam, + Invoker => Signature_Of (Invk_Id), + Kind => Kind, + Target => Signature_Of (Targ_Id), Update_Units => False); end Record_Invocation_Relation; @@ -13422,6 +13648,12 @@ package body Sem_Elab is if Legacy_Elaboration_Checks then return; + + -- Nothing to do when the elaboration phase of the compiler is not + -- active. + + elsif not Elaboration_Phase_Active then + return; end if; -- Eliminate a recorded scenario when it appears within dead code @@ -13433,6 +13665,18 @@ package body Sem_Elab is end Kill_Elaboration_Scenario; ---------------------- + -- Main_Unit_Entity -- + ---------------------- + + function Main_Unit_Entity return Entity_Id is + begin + -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of + -- generic bodies and may return an outdated entity. + + return Defining_Entity (Unit (Cunit (Main_Unit))); + end Main_Unit_Entity; + + ---------------------- -- Non_Private_View -- ---------------------- @@ -13785,6 +14029,12 @@ package body Sem_Elab is elsif Preanalysis_Active then return; + + -- Nothing to do when the elaboration phase of the compiler is not + -- active. + + elsif not Elaboration_Phase_Active then + return; end if; Scen_Lvl := Find_Enclosing_Level (Scen); @@ -13889,16 +14139,11 @@ package body Sem_Elab is -- The following sets store all scenarios - Declaration_Scenarios : NE_Set.Membership_Set := - NE_Set.Create (1000); - Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := - NE_Set.Create (500); - Library_Body_Scenarios : NE_Set.Membership_Set := - NE_Set.Create (1000); - Library_Spec_Scenarios : NE_Set.Membership_Set := - NE_Set.Create (1000); - SPARK_Scenarios : NE_Set.Membership_Set := - NE_Set.Create (100); + Declaration_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; + Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; + Library_Body_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; + Library_Spec_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; + SPARK_Scenarios : NE_Set.Membership_Set := NE_Set.Nil; ------------------------------- -- Finalize_Scenario_Storage -- @@ -13919,7 +14164,11 @@ package body Sem_Elab is procedure Initialize_Scenario_Storage is begin - null; + Declaration_Scenarios := NE_Set.Create (1000); + Dynamic_ABE_Check_Scenarios := NE_Set.Create (500); + Library_Body_Scenarios := NE_Set.Create (1000); + Library_Spec_Scenarios := NE_Set.Create (1000); + SPARK_Scenarios := NE_Set.Create (100); end Initialize_Scenario_Storage; ------------------------------ @@ -14796,6 +15045,15 @@ package body Sem_Elab is end Is_Up_Level_Target; end Semantics; + --------------------------- + -- Set_Elaboration_Phase -- + --------------------------- + + procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status) is + begin + Elaboration_Phase := Status; + end Set_Elaboration_Phase; + --------------------- -- SPARK_Processor -- --------------------- @@ -14855,8 +15113,7 @@ package body Sem_Elab is -- emitted multiple times. procedure Check_SPARK_Model_In_Effect is - Spec_Id : constant Entity_Id := - Unique_Entity (Cunit_Entity (Main_Unit)); + Spec_Id : constant Entity_Id := Unique_Entity (Main_Unit_Entity); begin -- Do not emit the warning multiple times as this creates useless @@ -15700,17 +15957,24 @@ package body Sem_Elab is procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is begin + -- Nothing to do when the elaboration phase of the compiler is not + -- active. + + if not Elaboration_Phase_Active then + return; + -- Nothing to do when the old and new scenarios are one and the same - if Old_N = New_N then + elsif Old_N = New_N then return; + end if; -- A scenario is being transformed by Atree.Rewrite. Update all relevant -- internal data structures to reflect this change. This ensures that a -- potential run-time conditional ABE check or a guaranteed ABE failure -- is inserted at the proper place in the tree. - elsif Is_Scenario (Old_N) then + if Is_Scenario (Old_N) then Replace_Scenario (Old_N, New_N); end if; end Update_Elaboration_Scenario; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 4956ef3..734c961 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -986,6 +986,13 @@ package body Sem_Eval is Lf : constant Node_Id := Compare_Fixup (L); Rf : constant Node_Id := Compare_Fixup (R); + function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean; + -- An attribute reference to Loop_Entry may have been rewritten into + -- its prefix as a way to avoid generating a constant for that + -- attribute when the corresponding pragma is ignored. These nodes + -- should be ignored when deciding if they can be equal to one + -- another. + function Is_Same_Subscript (L, R : List_Id) return Boolean; -- L, R are the Expressions values from two attribute nodes for First -- or Last attributes. Either may be set to No_List if no expressions @@ -993,6 +1000,19 @@ package body Sem_Eval is -- expressions represent the same subscript (note one case is where -- one subscript is missing and the other is explicitly set to 1). + ----------------------------- + -- Is_Rewritten_Loop_Entry -- + ----------------------------- + + function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean is + Orig_N : constant Node_Id := Original_Node (N); + begin + return Orig_N /= N + and then Nkind (Orig_N) = N_Attribute_Reference + and then Get_Attribute_Id (Attribute_Name (Orig_N)) = + Attribute_Loop_Entry; + end Is_Rewritten_Loop_Entry; + ----------------------- -- Is_Same_Subscript -- ----------------------- @@ -1018,23 +1038,32 @@ package body Sem_Eval is -- Start of processing for Is_Same_Value begin - -- Values are the same if they refer to the same entity and the - -- entity is non-volatile. This does not however apply to Float - -- types, since we may have two NaN values and they should never - -- compare equal. + -- Loop_Entry nodes rewritten into their prefix inside ignored + -- pragmas should never lead to a decision of equality. - -- If the entity is a discriminant, the two expressions may be bounds - -- of components of objects of the same discriminated type. The - -- values of the discriminants are not static, and therefore the - -- result is unknown. + if Is_Rewritten_Loop_Entry (Lf) + or else Is_Rewritten_Loop_Entry (Rf) + then + return False; - -- It would be better to comment individual branches of this test ??? + -- Values are the same if they refer to the same entity and the + -- entity is nonvolatile. - if Nkind_In (Lf, N_Identifier, N_Expanded_Name) + elsif Nkind_In (Lf, N_Identifier, N_Expanded_Name) and then Nkind_In (Rf, N_Identifier, N_Expanded_Name) and then Entity (Lf) = Entity (Rf) + + -- If the entity is a discriminant, the two expressions may be + -- bounds of components of objects of the same discriminated type. + -- The values of the discriminants are not static, and therefore + -- the result is unknown. + and then Ekind (Entity (Lf)) /= E_Discriminant and then Present (Entity (Lf)) + + -- This does not however apply to Float types, since we may have + -- two NaN values and they should never compare equal. + and then not Is_Floating_Point_Type (Etype (L)) and then not Is_Volatile_Reference (L) and then not Is_Volatile_Reference (R) @@ -4281,7 +4310,15 @@ package body Sem_Eval is return Ent; else pragma Assert (Ekind (Ent) = E_Constant); - return Expr_Value_E (Constant_Value (Ent)); + + -- We may be dealing with a enumerated character type constant, so + -- handle that case here. + + if Nkind (Constant_Value (Ent)) = N_Character_Literal then + return Ent; + else + return Expr_Value_E (Constant_Value (Ent)); + end if; end if; end Expr_Value_E; @@ -4611,10 +4648,14 @@ package body Sem_Eval is -- will cause semantic errors if it is marked as static), and after -- the Resolve step (since Resolve in some cases sets this flag). + -- We mark the node as analyzed so that its type is not erased by + -- calling Analyze_Real_Literal. + Analyze (N); Set_Is_Static_Expression (N, Static); Set_Etype (N, Typ); Resolve (N); + Set_Analyzed (N); Set_Is_Static_Expression (N, Static); end Fold_Ureal; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b499dbd..1a2a759 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -41,6 +41,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Dist; use Exp_Dist; with Exp_Util; use Exp_Util; +with Expander; use Expander; with Freeze; use Freeze; with Ghost; use Ghost; with Gnatvsn; use Gnatvsn; @@ -298,6 +299,12 @@ package body Sem_Prag is -- pragma. Entity name for unit and its parents is taken from item in -- previous with_clause that mentions the unit. + procedure Validate_Compile_Time_Warning_Error (N : Node_Id); + -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean + -- expression is not known at compile time. This procedure makes an entry + -- in a table. The actual checking is performed by Validate_Compile_Time_ + -- Warning_Errors, which is invoked after calling the back end. + Dummy : Integer := 0; pragma Volatile (Dummy); -- Dummy volatile integer used in bodies of ip/rv to prevent optimization @@ -316,6 +323,41 @@ package body Sem_Prag is -- pragma in the source program, a breakpoint on rv catches this place in -- the source, allowing convenient stepping to the point of interest. + --------------------------------------------------- + -- Table for Validate_Compile_Time_Warning_Error -- + --------------------------------------------------- + + -- The following table collects pragmas Compile_Time_Error and Compile_ + -- Time_Warning for validation. Entries are made by calls to subprogram + -- Validate_Compile_Time_Warning_Error, and the call to the procedure + -- Validate_Compile_Time_Warning_Errors does the actual error checking + -- and posting of warning and error messages. The reason for this delayed + -- processing is to take advantage of back-annotations of attributes size + -- and alignment values performed by the back end. + + -- Note: the reason we store a Source_Ptr value instead of a Node_Id is + -- that by the time Validate_Unchecked_Conversions is called, Sprint will + -- already have modified all Sloc values if the -gnatD option is set. + + type CTWE_Entry is record + Eloc : Source_Ptr; + -- Source location used in warnings and error messages + + Prag : Node_Id; + -- Pragma Compile_Time_Error or Compile_Time_Warning + + Scope : Node_Id; + -- The scope which encloses the pragma + end record; + + package Compile_Time_Warnings_Errors is new Table.Table ( + Table_Component_Type => CTWE_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Compile_Time_Warnings_Errors"); + ------------------------------- -- Adjust_External_Name_Case -- ------------------------------- @@ -7605,7 +7647,7 @@ package body Sem_Prag is Check_Expression (Arg1x); if Validation_Needed then - Sem_Ch13.Validate_Compile_Time_Warning_Error (N); + Validate_Compile_Time_Warning_Error (N); end if; end if; end Process_Compile_Time_Warning_Or_Error; @@ -8921,8 +8963,7 @@ package body Sem_Prag is Mark_Rewrite_Insertion (Decl); else - Error_Pragma_Arg ("no matching type found for pragma%", - Arg2); + Error_Pragma_Arg ("no matching type found for pragma%", Arg2); end if; end Process_Import_Predefined_Type; @@ -13579,8 +13620,8 @@ package body Sem_Prag is -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- ------------------------------------------------------------------ - -- pragma Asynch_Readers [ (boolean_EXPRESSION) ]; - -- pragma Asynch_Writers [ (boolean_EXPRESSION) ]; + -- pragma Async_Readers [ (boolean_EXPRESSION) ]; + -- pragma Async_Writers [ (boolean_EXPRESSION) ]; -- pragma Effective_Reads [ (boolean_EXPRESSION) ]; -- pragma Effective_Writes [ (boolean_EXPRESSION) ]; @@ -14072,9 +14113,14 @@ package body Sem_Prag is Expr := Get_Pragma_Arg (Arg2); - -- Deal with SCO generation + -- Mark the pragma (or, if rewritten from an aspect, the original + -- aspect) as enabled. Nothing to do for an internally generated + -- check for a dynamic predicate. - if Is_Checked (N) and then not Split_PPC (N) then + if Is_Checked (N) + and then not Split_PPC (N) + and then Cname /= Name_Dynamic_Predicate + then Set_SCO_Pragma_Enabled (Loc); end if; @@ -23189,7 +23235,16 @@ package body Sem_Prag is -- Start of processing for Check_Library_Level_Entity begin - if not Is_Library_Level_Entity (E) then + -- A SPARK_Mode of On shall only apply to library-level + -- entities, except for those in generic instances, which are + -- ignored (even if the entity gets SPARK_Mode pragma attached + -- in the AST, its effect is not taken into account unless the + -- context already provides SPARK_Mode of On in GNATprove). + + if Get_SPARK_Mode_From_Annotation (N) = On + and then not Is_Library_Level_Entity (E) + and then Instantiation_Location (Sloc (N)) = No_Location + then Error_Msg_Name_1 := Pname; Error_Msg_N (Fix_Error (Msg_1), N); @@ -25737,7 +25792,7 @@ package body Sem_Prag is -- 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 + -- 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 @@ -30715,6 +30770,7 @@ package body Sem_Prag is procedure Initialize is begin Externals.Init; + Compile_Time_Warnings_Errors.Init; end Initialize; -------- @@ -32057,4 +32113,77 @@ package body Sem_Prag is return Empty; end Test_Case_Arg; + ----------------------------------------- + -- Validate_Compile_Time_Warning_Error -- + ----------------------------------------- + + procedure Validate_Compile_Time_Warning_Error (N : Node_Id) is + begin + Compile_Time_Warnings_Errors.Append + (New_Val => CTWE_Entry'(Eloc => Sloc (N), + Scope => Current_Scope, + Prag => N)); + end Validate_Compile_Time_Warning_Error; + + ------------------------------------------ + -- Validate_Compile_Time_Warning_Errors -- + ------------------------------------------ + + procedure Validate_Compile_Time_Warning_Errors is + procedure Set_Scope (S : Entity_Id); + -- Install all enclosing scopes of S along with S itself + + procedure Unset_Scope (S : Entity_Id); + -- Uninstall all enclosing scopes of S along with S itself + + --------------- + -- Set_Scope -- + --------------- + + procedure Set_Scope (S : Entity_Id) is + begin + if S /= Standard_Standard then + Set_Scope (Scope (S)); + end if; + + Push_Scope (S); + end Set_Scope; + + ----------------- + -- Unset_Scope -- + ----------------- + + procedure Unset_Scope (S : Entity_Id) is + begin + if S /= Standard_Standard then + Unset_Scope (Scope (S)); + end if; + + Pop_Scope; + end Unset_Scope; + + -- Start of processing for Validate_Compile_Time_Warning_Errors + + begin + Expander_Mode_Save_And_Set (False); + In_Compile_Time_Warning_Or_Error := True; + + for N in Compile_Time_Warnings_Errors.First .. + Compile_Time_Warnings_Errors.Last + loop + declare + T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N); + + begin + Set_Scope (T.Scope); + Reset_Analyzed_Flags (T.Prag); + Process_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc); + Unset_Scope (T.Scope); + end; + end loop; + + In_Compile_Time_Warning_Or_Error := False; + Expander_Mode_Restore; + end Validate_Compile_Time_Warning_Errors; + end Sem_Prag; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index f2f6d0c..25353b7 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -555,4 +555,10 @@ package Sem_Prag is -- -- Empty if there is no such argument + procedure Validate_Compile_Time_Warning_Errors; + -- This routine is called after calling the back end to validate pragmas + -- Compile_Time_Error and Compile_Time_Warning for size and alignment + -- appropriateness. The reason it is called that late is to take advantage + -- of any back-annotation of size and alignment performed by the back end. + end Sem_Prag; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8521478..b668a51 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -111,8 +111,8 @@ package body Sem_Res is Pref : Node_Id); -- Check that the type of the prefix of a dereference is not incomplete - function Check_Infinite_Recursion (N : Node_Id) return Boolean; - -- Given a call node, N, which is known to occur immediately within the + function Check_Infinite_Recursion (Call : Node_Id) return Boolean; + -- Given a call node, Call, which is known to occur immediately within the -- subprogram being called, determines whether it is a detectable case of -- an infinite recursion, and if so, outputs appropriate messages. Returns -- True if an infinite recursion is detected, and False otherwise. @@ -159,7 +159,7 @@ package body Sem_Res is Typ : Entity_Id; Is_Comp : Boolean); -- Internal procedure for Resolve_Op_Concat to resolve one operand of - -- concatenation operator. The operand is either of the array type or of + -- concatenation operator. The operand is either of the array type or of -- the component type. If the operand is an aggregate, and the component -- type is composite, this is ambiguous if component type has aggregates. @@ -695,164 +695,398 @@ package body Sem_Res is -- Check_Infinite_Recursion -- ------------------------------ - function Check_Infinite_Recursion (N : Node_Id) return Boolean is - P : Node_Id; - C : Node_Id; + function Check_Infinite_Recursion (Call : Node_Id) return Boolean is + function Enclosing_Declaration_Or_Statement (N : Node_Id) return Node_Id; + -- Return the nearest enclosing declaration or statement that houses + -- arbitrary node N. - function Same_Argument_List return Boolean; - -- Check whether list of actuals is identical to list of formals of - -- called function (which is also the enclosing scope). + function Invoked_With_Different_Arguments (N : Node_Id) return Boolean; + -- Determine whether call N invokes the related enclosing subprogram + -- with actuals that differ from the subprogram's formals. - ------------------------ - -- Same_Argument_List -- - ------------------------ + function Is_Conditional_Statement (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N denotes a conditional construct + + function Is_Control_Flow_Statement (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N denotes a control flow statement + -- or a construct that may contains such a statement. + + function Is_Immediately_Within_Body (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears immediately within the + -- statements of an entry or subprogram body. + + function Is_Raise_Idiom (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears immediately within the + -- body of an entry or subprogram, and is preceded by a single raise + -- statement. + + function Is_Raise_Statement (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N denotes a raise statement + + function Is_Sole_Statement (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N is the sole source statement in + -- the body of the enclosing subprogram. + + function Preceded_By_Control_Flow_Statement (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N is preceded by a control flow + -- statement. + + function Within_Conditional_Statement (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N appears within a conditional + -- construct. + + ---------------------------------------- + -- Enclosing_Declaration_Or_Statement -- + ---------------------------------------- - function Same_Argument_List return Boolean is - A : Node_Id; - F : Entity_Id; - Subp : Entity_Id; + function Enclosing_Declaration_Or_Statement + (N : Node_Id) return Node_Id + is + Par : Node_Id; begin - if not Is_Entity_Name (Name (N)) then - return False; - else - Subp := Entity (Name (N)); - end if; + Par := N; + while Present (Par) loop + if Is_Declaration (Par) or else Is_Statement (Par) then + return Par; - F := First_Formal (Subp); - A := First_Actual (N); - while Present (F) and then Present (A) loop - if not Is_Entity_Name (A) or else Entity (A) /= F then - return False; + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; end if; - Next_Actual (A); - Next_Formal (F); + Par := Parent (Par); end loop; - return True; - end Same_Argument_List; + return N; + end Enclosing_Declaration_Or_Statement; - -- Start of processing for Check_Infinite_Recursion + -------------------------------------- + -- Invoked_With_Different_Arguments -- + -------------------------------------- - begin - -- Special case, if this is a procedure call and is a call to the - -- current procedure with the same argument list, then this is for - -- sure an infinite recursion and we insert a call to raise SE. + function Invoked_With_Different_Arguments (N : Node_Id) return Boolean is + Subp : constant Entity_Id := Entity (Name (N)); - if Is_List_Member (N) - and then List_Length (List_Containing (N)) = 1 - and then Same_Argument_List - then - declare - P : constant Node_Id := Parent (N); - begin - if Nkind (P) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (P)) = N_Subprogram_Body - and then Is_Empty_List (Declarations (Parent (P))) + Actual : Node_Id; + Formal : Entity_Id; + + begin + -- Determine whether the formals of the invoked subprogram are not + -- used as actuals in the call. + + Actual := First_Actual (Call); + Formal := First_Formal (Subp); + while Present (Actual) and then Present (Formal) loop + + -- The current actual does not match the current formal + + if not (Is_Entity_Name (Actual) + and then Entity (Actual) = Formal) then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_N ("!infinite recursion<<", N); - Error_Msg_N ("\!Storage_Error [<<", N); - Insert_Action (N, - Make_Raise_Storage_Error (Sloc (N), - Reason => SE_Infinite_Recursion)); return True; end if; - end; - end if; - -- If not that special case, search up tree, quitting if we reach a - -- construct (e.g. a conditional) that tells us that this is not a - -- case for an infinite recursion warning. + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + return False; + end Invoked_With_Different_Arguments; - C := N; - loop - P := Parent (C); + ------------------------------ + -- Is_Conditional_Statement -- + ------------------------------ - -- If no parent, then we were not inside a subprogram, this can for - -- example happen when processing certain pragmas in a spec. Just - -- return False in this case. + function Is_Conditional_Statement (N : Node_Id) return Boolean is + begin + return + Nkind_In (N, N_And_Then, + N_Case_Expression, + N_Case_Statement, + N_If_Expression, + N_If_Statement, + N_Or_Else); + end Is_Conditional_Statement; - if No (P) then - return False; + ------------------------------- + -- Is_Control_Flow_Statement -- + ------------------------------- + + function Is_Control_Flow_Statement (N : Node_Id) return Boolean is + begin + -- It is assumed that all statements may affect the control flow in + -- some way. A raise statement may be expanded into a non-statement + -- node. + + return Is_Statement (N) or else Is_Raise_Statement (N); + end Is_Control_Flow_Statement; + + -------------------------------- + -- Is_Immediately_Within_Body -- + -------------------------------- + + function Is_Immediately_Within_Body (N : Node_Id) return Boolean is + HSS : constant Node_Id := Parent (N); + + begin + return + Nkind (HSS) = N_Handled_Sequence_Of_Statements + and then Nkind_In (Parent (HSS), N_Entry_Body, N_Subprogram_Body) + and then Is_List_Member (N) + and then List_Containing (N) = Statements (HSS); + end Is_Immediately_Within_Body; + + -------------------- + -- Is_Raise_Idiom -- + -------------------- + + function Is_Raise_Idiom (N : Node_Id) return Boolean is + Raise_Stmt : Node_Id; + Stmt : Node_Id; + + begin + if Is_Immediately_Within_Body (N) then + + -- Assume that no raise statement has been seen yet + + Raise_Stmt := Empty; + + -- Examine the statements preceding the input node, skipping + -- internally-generated constructs. + + Stmt := Prev (N); + while Present (Stmt) loop + + -- Multiple raise statements violate the idiom + + if Is_Raise_Statement (Stmt) then + if Present (Raise_Stmt) then + return False; + end if; + + Raise_Stmt := Stmt; + + elsif Comes_From_Source (Stmt) then + exit; + end if; + + Stmt := Prev (Stmt); + end loop; + + -- At this point the node must be preceded by a raise statement, + -- and the raise statement has to be the sole statement within + -- the enclosing entry or subprogram body. + + return + Present (Raise_Stmt) and then Is_Sole_Statement (Raise_Stmt); end if; - -- Done if we get to subprogram body, this is definitely an infinite - -- recursion case if we did not find anything to stop us. + return False; + end Is_Raise_Idiom; - exit when Nkind (P) = N_Subprogram_Body; + ------------------------ + -- Is_Raise_Statement -- + ------------------------ - -- If appearing in conditional, result is false + function Is_Raise_Statement (N : Node_Id) return Boolean is + begin + -- A raise statement may be transfomed into a Raise_xxx_Error node - if Nkind_In (P, N_Or_Else, - N_And_Then, - N_Case_Expression, - N_Case_Statement, - N_If_Expression, - N_If_Statement) - then - return False; + return + Nkind (N) = N_Raise_Statement + or else Nkind (N) in N_Raise_xxx_Error; + end Is_Raise_Statement; - elsif Nkind (P) = N_Handled_Sequence_Of_Statements - and then C /= First (Statements (P)) - then - -- If the call is the expression of a return statement and the - -- actuals are identical to the formals, it's worth a warning. - -- However, we skip this if there is an immediately preceding - -- raise statement, since the call is never executed. + ----------------------- + -- Is_Sole_Statement -- + ----------------------- - -- Furthermore, this corresponds to a common idiom: + function Is_Sole_Statement (N : Node_Id) return Boolean is + Stmt : Node_Id; - -- function F (L : Thing) return Boolean is - -- begin - -- raise Program_Error; - -- return F (L); - -- end F; + begin + -- The input node appears within the statements of an entry or + -- subprogram body. Examine the statements preceding the node. - -- for generating a stub function + if Is_Immediately_Within_Body (N) then + Stmt := Prev (N); - if Nkind (Parent (N)) = N_Simple_Return_Statement - and then Same_Argument_List - then - exit when not Is_List_Member (Parent (N)); + while Present (Stmt) loop - -- OK, return statement is in a statement list, look for raise + -- The statement is preceded by another statement or a source + -- construct. This indicates that the node does not appear by + -- itself. - declare - Nod : Node_Id; + if Is_Control_Flow_Statement (Stmt) + or else Comes_From_Source (Stmt) + then + return False; + end if; - begin - -- Skip past N_Freeze_Entity nodes generated by expansion + Stmt := Prev (Stmt); + end loop; - Nod := Prev (Parent (N)); - while Present (Nod) - and then Nkind (Nod) = N_Freeze_Entity - loop - Prev (Nod); - end loop; + return True; + end if; - -- If no raise statement, give warning. We look at the - -- original node, because in the case of "raise ... with - -- ...", the node has been transformed into a call. + -- The input node is within a construct nested inside the entry or + -- subprogram body. - exit when Nkind (Original_Node (Nod)) /= N_Raise_Statement - and then - (Nkind (Nod) not in N_Raise_xxx_Error - or else Present (Condition (Nod))); - end; - end if; + return False; + end Is_Sole_Statement; - return False; + ---------------------------------------- + -- Preceded_By_Control_Flow_Statement -- + ---------------------------------------- - else - C := P; + function Preceded_By_Control_Flow_Statement + (N : Node_Id) return Boolean + is + Stmt : Node_Id; + + begin + if Is_List_Member (N) then + Stmt := Prev (N); + + -- Examine the statements preceding the input node + + while Present (Stmt) loop + if Is_Control_Flow_Statement (Stmt) then + return True; + end if; + + Stmt := Prev (Stmt); + end loop; + + return False; end if; - end loop; - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_N ("!possible infinite recursion<<", N); - Error_Msg_N ("\!??Storage_Error ]<<", N); + -- Assume that the node is part of some control flow statement + + return True; + end Preceded_By_Control_Flow_Statement; + + ---------------------------------- + -- Within_Conditional_Statement -- + ---------------------------------- + + function Within_Conditional_Statement (N : Node_Id) return Boolean is + Stmt : Node_Id; + + begin + Stmt := Parent (N); + while Present (Stmt) loop + if Is_Conditional_Statement (Stmt) then + return True; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Stmt) then + exit; + end if; + + Stmt := Parent (Stmt); + end loop; + + return False; + end Within_Conditional_Statement; + + -- Local variables + + Call_Context : constant Node_Id := + Enclosing_Declaration_Or_Statement (Call); + + -- Start of processing for Check_Infinite_Recursion + + begin + -- The call is assumed to be safe when the enclosing subprogram is + -- invoked with actuals other than its formals. + -- + -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is + -- begin + -- ... + -- Proc (A1, A2, ..., AN); + -- ... + -- end Proc; + + if Invoked_With_Different_Arguments (Call) then + return False; + + -- The call is assumed to be safe when the invocation of the enclosing + -- subprogram depends on a conditional statement. + -- + -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is + -- begin + -- ... + -- if Some_Condition then + -- Proc (F1, F2, ..., FN); + -- end if; + -- ... + -- end Proc; + + elsif Within_Conditional_Statement (Call) then + return False; + + -- The context of the call is assumed to be safe when the invocation of + -- the enclosing subprogram is preceded by some control flow statement. + -- + -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is + -- begin + -- ... + -- if Some_Condition then + -- ... + -- end if; + -- ... + -- Proc (F1, F2, ..., FN); + -- ... + -- end Proc; + + elsif Preceded_By_Control_Flow_Statement (Call_Context) then + return False; + + -- Detect an idiom where the context of the call is preceded by a single + -- raise statement. + -- + -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is + -- begin + -- raise ...; + -- Proc (F1, F2, ..., FN); + -- end Proc; + + elsif Is_Raise_Idiom (Call_Context) then + return False; + end if; + + -- At this point it is certain that infinite recursion will take place + -- as long as the call is executed. Detect a case where the context of + -- the call is the sole source statement within the subprogram body. + -- + -- procedure Proc (F1 : ...; F2 : ...; ...; FN : ...) is + -- begin + -- Proc (F1, F2, ..., FN); + -- end Proc; + -- + -- Install an explicit raise to prevent the infinite recursion. + + if Is_Sole_Statement (Call_Context) then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_N ("!infinite recursion<<", Call); + Error_Msg_N ("\!Storage_Error [<<", Call); + + Insert_Action (Call, + Make_Raise_Storage_Error (Sloc (Call), + Reason => SE_Infinite_Recursion)); + + -- Otherwise infinite recursion could take place, considering other flow + -- control constructs such as gotos, exit statements, etc. + + else + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_N ("!possible infinite recursion<<", Call); + Error_Msg_N ("\!??Storage_Error ]<<", Call); + end if; return True; end Check_Infinite_Recursion; @@ -3224,12 +3458,17 @@ package body Sem_Res is begin -- Nothing to do if no parameters, or original node is neither a -- function call nor a procedure call statement (happens in the - -- operator-transformed-to-function call case), or the call does + -- operator-transformed-to-function call case), or the call is to an + -- operator symbol (which is usually in infix form), or the call does -- not come from source, or this warning is off. if not Warn_On_Parameter_Order or else No (Parameter_Associations (N)) or else Nkind (Original_Node (N)) not in N_Subprogram_Call + or else (Nkind (Name (N)) = N_Identifier + and then Present (Entity (Name (N))) + and then Nkind (Entity (Name (N))) = + N_Defining_Operator_Symbol) or else not Comes_From_Source (N) then return; @@ -3951,17 +4190,16 @@ package body Sem_Res is DDT : constant Entity_Id := Directly_Designated_Type (Base_Type (Etype (F))); - New_Itype : Entity_Id; - begin + -- Displace the pointer to the object to reference its + -- secondary dispatch table. + if Is_Class_Wide_Type (DDT) and then Is_Interface (DDT) then - New_Itype := Create_Itype (E_Anonymous_Access_Type, A); - Set_Etype (New_Itype, Etype (A)); - Set_Directly_Designated_Type - (New_Itype, Directly_Designated_Type (Etype (A))); - Set_Etype (A, New_Itype); + Rewrite (A, Convert_To (Etype (F), Relocate_Node (A))); + Analyze_And_Resolve (A, Etype (F), + Suppress => Access_Check); end if; -- Ada 2005, AI-162:If the actual is an allocator, the @@ -6070,7 +6308,7 @@ package body Sem_Res is -- is frozen in the usual fashion, by the appearance of a real body, -- or at the end of a declarative part. However an implicit call to -- an expression function may appear when it is part of a default - -- expression in a call to an initialiation procedure, and must be + -- expression in a call to an initialization procedure, and must be -- frozen now, even if the body is inserted at a later point. if Is_Entity_Name (Subp) @@ -6710,7 +6948,9 @@ package body Sem_Res is -- Check the dimensions of the actuals in the call. For function calls, -- propagate the dimensions from the returned type to N. - Analyze_Dimension_Call (N, Nam); + if not In_Inlined_Body then + Analyze_Dimension_Call (N, Nam); + end if; -- All done, evaluate call and deal with elaboration issues @@ -6768,6 +7008,15 @@ package body Sem_Res is Cannot_Inline ("cannot inline & (in default expression)?", N, Nam_UA); + -- Calls cannot be inlined inside quantified expressions, which + -- are left in expression form for GNATprove. Since these + -- expressions are only preanalyzed, we need to detect the failure + -- to inline outside of the case for Full_Analysis below. + + elsif In_Quantified_Expression (N) then + Cannot_Inline + ("cannot inline & (in quantified expression)?", N, Nam_UA); + -- Inlining should not be performed during preanalysis elsif Full_Analysis then @@ -8194,6 +8443,51 @@ package body Sem_Res is Explain_Redundancy (Original_Node (R)); end if; + -- If the equality is overloaded and the operands have resolved + -- properly, set the proper equality operator on the node. The + -- current setting is the first one found during analysis, which + -- is not necessarily the one to which the node has resolved. + + if Is_Overloaded (N) then + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (N, I, It); + + -- If the equality is user-defined, the type of the operands + -- matches that of the formals. For a predefined operqtor, + -- it is the scope that matters, given that the predefined + -- equality has Any_Type formals. In either case the result + -- type (most often Booleam) must match the context . + + while Present (It.Typ) loop + if Etype (It.Nam) = Typ + and then + (Etype (First_Entity (It.Nam)) = Etype (L) + or else Scope (It.Nam) = Scope (T)) + then + Set_Entity (N, It.Nam); + + Set_Is_Overloaded (N, False); + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + + -- If expansion is active and this is an inherited operation, + -- replace it with its ancestor. This must not be done during + -- preanalysis because the type may not be frozen yet, as when + -- the context is a precondition or postcondition. + + if Present (Alias (Entity (N))) and then Expander_Active then + Set_Entity (N, Alias (Entity (N))); + end if; + end; + end if; + Check_Unset_Reference (L); Check_Unset_Reference (R); Generate_Operator_Reference (N, T); @@ -9791,9 +10085,42 @@ package body Sem_Res is end if; -- Complete resolution and evaluation of NOT + -- If argument is an equality and expected type is boolean, that + -- expected type has no effect on resolution, and there are + -- special rules for resolution of Eq, Neq in the presence of + -- overloaded operands, so we directly call its resolution routines. + + declare + Opnd : constant Node_Id := Right_Opnd (N); + Op_Id : Entity_Id; + + begin + if B_Typ = Standard_Boolean + and then Nkind_In (Opnd, N_Op_Eq, N_Op_Ne) + and then Is_Overloaded (Opnd) + then + Resolve_Equality_Op (Opnd, B_Typ); + Op_Id := Entity (Opnd); + + if Ekind (Op_Id) = E_Function + and then not Is_Intrinsic_Subprogram (Op_Id) + then + Rewrite_Operator_As_Call (Opnd, Op_Id); + end if; + + if not Inside_A_Generic or else Is_Entity_Name (Opnd) then + Freeze_Expression (Opnd); + end if; + + Expand (Opnd); + + else + Resolve (Opnd, B_Typ); + end if; + + Check_Unset_Reference (Opnd); + end; - Resolve (Right_Opnd (N), B_Typ); - Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); Generate_Operator_Reference (N, B_Typ); Eval_Op_Not (N); @@ -10297,8 +10624,25 @@ package body Sem_Res is if Is_Access_Type (Etype (P)) then T := Designated_Type (Etype (P)); Check_Fully_Declared_Prefix (T, P); + else T := Etype (P); + + -- If the prefix is an entity it may have a deferred reference set + -- during analysis of the selected component. After resolution we + -- can transform it into a proper reference. This prevents spurious + -- warnings on useless assignments when the same selected component + -- is the actual for an out parameter in a subsequent call. + + if Is_Entity_Name (P) + and then Has_Deferred_Reference (Entity (P)) + then + if May_Be_Lvalue (N) then + Generate_Reference (Entity (P), P, 'm'); + else + Generate_Reference (Entity (P), P, 'r'); + end if; + end if; end if; -- Set flag for expander if discriminant check required on a component diff --git a/gcc/ada/sem_spark.adb b/gcc/ada/sem_spark.adb index b4e816e..a60a6cb 100644 --- a/gcc/ada/sem_spark.adb +++ b/gcc/ada/sem_spark.adb @@ -137,6 +137,9 @@ package body Sem_SPARK is -- corresponds to both "observing" and "owning" types in SPARK RM -- 3.10. To be used when moving the path. + Explanation : Node_Id; + -- Node that can be used in an explanation for a permission mismatch + case Kind is -- An entire object is either a leaf (an object which cannot be -- extended further in a path) or a subtree in folded form (which @@ -217,6 +220,7 @@ package body Sem_SPARK is function Children_Permission (T : Perm_Tree_Access) return Perm_Kind; function Component (T : Perm_Tree_Access) return Perm_Tree_Maps.Instance; + function Explanation (T : Perm_Tree_Access) return Node_Id; function Get_All (T : Perm_Tree_Access) return Perm_Tree_Access; function Get_Elem (T : Perm_Tree_Access) return Perm_Tree_Access; function Is_Node_Deep (T : Perm_Tree_Access) return Boolean; @@ -257,6 +261,7 @@ package body Sem_SPARK is (N : Node_Id; Exp_Perm : Perm_Kind; Act_Perm : Perm_Kind; + Expl : Node_Id; Forbidden_Perm : Boolean := False); -- Issues a continuation error message about a mismatch between a -- desired permission Exp_Perm and a permission obtained Act_Perm. N @@ -428,6 +433,15 @@ package body Sem_SPARK is Free_Perm_Tree_Dealloc (PT); end Free_Tree; + ----------------- + -- Explanation -- + ----------------- + + function Explanation (T : Perm_Tree_Access) return Node_Id is + begin + return T.all.Tree.Explanation; + end Explanation; + ------------- -- Get_All -- ------------- @@ -503,22 +517,34 @@ package body Sem_SPARK is (N : Node_Id; Exp_Perm : Perm_Kind; Act_Perm : Perm_Kind; + Expl : Node_Id; Forbidden_Perm : Boolean := False) is begin + Error_Msg_Sloc := Sloc (Expl); + if Forbidden_Perm then - if Exp_Perm = Act_Perm then - Error_Msg_N ("\got forbidden state `" - & Perm_Kind'Image (Exp_Perm), N); + if Exp_Perm = No_Access then + Error_Msg_N ("\object was moved #", N); else - Error_Msg_N ("\forbidden state `" - & Perm_Kind'Image (Exp_Perm) & "`, got `" - & Perm_Kind'Image (Act_Perm) & "`", N); + raise Program_Error; end if; else - Error_Msg_N ("\expected state `" - & Perm_Kind'Image (Exp_Perm) & "` at least, got `" - & Perm_Kind'Image (Act_Perm) & "`", N); + case Exp_Perm is + when Write_Perm => + if Act_Perm = Read_Only then + Error_Msg_N + ("\object was declared as not writeable #", N); + else + Error_Msg_N ("\object was moved #", N); + end if; + + when Read_Only => + Error_Msg_N ("\object was moved #", N); + + when No_Access => + raise Program_Error; + end case; end if; end Perm_Mismatch; @@ -534,9 +560,13 @@ package body Sem_SPARK is -- has the right permission, and also updating permissions when a path is -- moved, borrowed, or observed. - type Checking_Mode is + type Extended_Checking_Mode is + + (Read_Subexpr, + -- Special value used for assignment, to check that subexpressions of + -- the assigned path are readable. - (Read, + Read, -- Default mode Move, @@ -565,6 +595,8 @@ package body Sem_SPARK is -- and extensions are set to Read_Only. ); + subtype Checking_Mode is Extended_Checking_Mode range Read .. Observe; + type Result_Kind is (Folded, Unfolded); -- The type declaration to discriminate in the Perm_Or_Tree type @@ -575,8 +607,11 @@ package body Sem_SPARK is type Perm_Or_Tree (R : Result_Kind) is record case R is - when Folded => Found_Permission : Perm_Kind; - when Unfolded => Tree_Access : Perm_Tree_Access; + when Folded => + Found_Permission : Perm_Kind; + Explanation : Node_Id; + when Unfolded => + Tree_Access : Perm_Tree_Access; end case; end record; @@ -602,10 +637,12 @@ package body Sem_SPARK is procedure Check_Declaration (Decl : Node_Id); - procedure Check_Expression (Expr : Node_Id; Mode : Checking_Mode); + procedure Check_Expression (Expr : Node_Id; Mode : Extended_Checking_Mode); pragma Precondition (Nkind_In (Expr, N_Index_Or_Discriminant_Constraint, N_Range_Constraint, - N_Subtype_Indication) + N_Subtype_Indication, + N_Digits_Constraint, + N_Delta_Constraint) or else Nkind (Expr) in N_Subexpr); procedure Check_Globals (Subp : Entity_Id); @@ -650,6 +687,10 @@ package body Sem_SPARK is -- Check that type Typ is either not deep, or that it is an observing or -- owning type according to SPARK RM 3.10 + function Get_Expl (N : Node_Or_Entity_Id) return Node_Id; + -- The function that takes a name as input and returns an explanation node + -- for the permission associated with it. + function Get_Observed_Or_Borrowed_Expr (Expr : Node_Id) return Node_Id; pragma Precondition (Is_Path_Expression (Expr)); -- Return the expression being borrowed/observed when borrowing or @@ -674,11 +715,14 @@ package body Sem_SPARK is function Get_Root_Object (Expr : Node_Id; - Through_Traversal : Boolean := True) return Entity_Id; - pragma Precondition (Is_Path_Expression (Expr)); + Through_Traversal : Boolean := True; + Is_Traversal : Boolean := False) return Entity_Id; -- Return the root of the path expression Expr, or Empty for an allocator, -- NULL, or a function call. Through_Traversal is True if it should follow - -- through calls to traversal functions. + -- through calls to traversal functions. Is_Traversal is True if this + -- corresponds to a value returned from a traversal function, which should + -- allow if-expressions and case-expressions that refer to the same root, + -- even if the paths are not the same in all branches. generic with procedure Handle_Parameter_Or_Global @@ -700,25 +744,30 @@ package body Sem_SPARK is -- the debugger to look into a hash table. pragma Unreferenced (Hp); - procedure Illegal_Global_Usage (N : Node_Or_Entity_Id); + procedure Illegal_Global_Usage (N : Node_Or_Entity_Id; E : Entity_Id); pragma No_Return (Illegal_Global_Usage); -- A procedure that is called when deep globals or aliased globals are used -- without any global aspect. - function Is_Deep (Typ : Entity_Id) return Boolean; - -- A function that can tell if a type is deep or not. Returns true if the - -- type passed as argument is deep. + function Is_Path_Expression + (Expr : Node_Id; + Is_Traversal : Boolean := False) return Boolean; + -- Return whether Expr corresponds to a path. Is_Traversal is True if this + -- corresponds to a value returned from a traversal function, which should + -- allow if-expressions and case-expressions. - function Is_Path_Expression (Expr : Node_Id) return Boolean; - -- Return whether Expr corresponds to a path + function Is_Subpath_Expression + (Expr : Node_Id; + Is_Traversal : Boolean := False) return Boolean; + -- Return True if Expr can be part of a path expression. Is_Traversal is + -- True if this corresponds to a value returned from a traversal function, + -- which should allow if-expressions and case-expressions. function Is_Prefix_Or_Almost (Pref, Expr : Node_Id) return Boolean; -- Determine if the candidate Prefix is indeed a prefix of Expr, or almost -- a prefix, in the sense that they could still refer to overlapping memory -- locations. - function Is_Traversal_Function (E : Entity_Id) return Boolean; - function Is_Traversal_Function_Call (Expr : Node_Id) return Boolean; function Loop_Of_Exit (N : Node_Id) return Entity_Id; @@ -732,6 +781,7 @@ package body Sem_SPARK is (N : Node_Id; Perm : Perm_Kind; Found_Perm : Perm_Kind; + Expl : Node_Id; Forbidden_Perm : Boolean := False); -- A procedure that is called when the permissions found contradict the -- rules established by the RM. This function is called with the node and @@ -742,7 +792,8 @@ package body Sem_SPARK is (E : Entity_Id; Subp : Entity_Id; Perm : Perm_Kind; - Found_Perm : Perm_Kind); + Found_Perm : Perm_Kind; + Expl : Node_Id); -- A procedure that is called when the permissions found contradict the -- rules established by the RM at the end of subprograms. This function is -- called with the node, the node of the returning function, and the @@ -772,12 +823,18 @@ package body Sem_SPARK is -- subprogram indeed have Read_Write permission at the end of the -- subprogram execution. - procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind); + procedure Set_Perm_Extensions + (T : Perm_Tree_Access; + P : Perm_Kind; + Expl : Node_Id); -- This procedure takes an access to a permission tree and modifies the -- tree so that any strict extensions of the given tree become of the -- access specified by parameter P. - procedure Set_Perm_Extensions_Move (T : Perm_Tree_Access; E : Entity_Id); + procedure Set_Perm_Extensions_Move + (T : Perm_Tree_Access; + E : Entity_Id; + Expl : Node_Id); -- Set permissions to -- No for any extension with more .all -- W for any deep extension with same number of .all @@ -785,7 +842,8 @@ package body Sem_SPARK is function Set_Perm_Prefixes (N : Node_Id; - Perm : Perm_Kind_Option) return Perm_Tree_Access; + Perm : Perm_Kind_Option; + Expl : Node_Id) return Perm_Tree_Access; pragma Precondition (Is_Path_Expression (N)); -- This function modifies the permissions of a given node in the permission -- environment as well as all the prefixes of the path, to the new @@ -817,13 +875,18 @@ package body Sem_SPARK is Typ : Entity_Id; Kind : Formal_Kind; Subp : Entity_Id; - Global_Var : Boolean); + Global_Var : Boolean; + Expl : Node_Id); -- Auxiliary procedure to Setup_Parameters and Setup_Globals procedure Setup_Parameters (Subp : Entity_Id); -- Takes a subprogram as input, and sets up the environment by adding -- formal parameters with appropriate permissions. + procedure Setup_Protected_Components (Subp : Entity_Id); + -- Takes a protected operation as input, and sets up the environment by + -- adding protected components with appropriate permissions. + ---------------------- -- Global Variables -- ---------------------- @@ -903,7 +966,7 @@ package body Sem_SPARK is null; else Handle_Parameter_Or_Global (Expr => Item, - Formal_Typ => Etype (Item), + Formal_Typ => Retysp (Etype (Item)), Param_Mode => Kind, Subp => Subp, Global_Var => True); @@ -1020,9 +1083,12 @@ package body Sem_SPARK is and then (Is_Traversal_Function_Call (Expr) or else Get_Root_Object (Borrowed) /= Var) then - Error_Msg_NE - ("source of assignment must have & as root (SPARK RM 3.10(8)))", - Expr, Var); + if Emit_Messages then + Error_Msg_NE + ("source of assignment must have & as root" & + " (SPARK RM 3.10(8)))", + Expr, Var); + end if; return; end if; @@ -1049,9 +1115,12 @@ package body Sem_SPARK is and then (Is_Traversal_Function_Call (Expr) or else Get_Root_Object (Observed) /= Var) then - Error_Msg_NE - ("source of assignment must have & as root (SPARK RM 3.10(8)))", - Expr, Var); + if Emit_Messages then + Error_Msg_NE + ("source of assignment must have & as root" & + " (SPARK RM 3.10(8)))", + Expr, Var); + end if; return; end if; @@ -1106,6 +1175,7 @@ package body Sem_SPARK is if Perm = No_Access then Perm_Error (Expr, No_Access, No_Access, + Expl => Get_Expl (Expr), Forbidden_Perm => True); return; end if; @@ -1114,6 +1184,7 @@ package body Sem_SPARK is if Perm = No_Access then Perm_Error (Expr, No_Access, No_Access, + Expl => Get_Expl (Expr_Root), Forbidden_Perm => True); return; end if; @@ -1133,21 +1204,25 @@ package body Sem_SPARK is Perm := Get_Perm (Expr); if Perm /= Read_Write then - Perm_Error (Expr, Read_Write, Perm); + Perm_Error (Expr, Read_Write, Perm, Expl => Get_Expl (Expr)); return; end if; if not Is_Decl then if not Is_Entity_Name (Target) then - Error_Msg_N - ("target of borrow must be stand-alone variable", - Target); + if Emit_Messages then + Error_Msg_N + ("target of borrow must be stand-alone variable", + Target); + end if; return; elsif Target_Root /= Expr_Root then - Error_Msg_NE - ("source of borrow must be variable &", - Expr, Target); + if Emit_Messages then + Error_Msg_NE + ("source of borrow must be variable &", + Expr, Target); + end if; return; end if; end if; @@ -1162,7 +1237,9 @@ package body Sem_SPARK is Check_Expression (Expr, Move); else - Error_Msg_N ("expression not allowed as source of move", Expr); + if Emit_Messages then + Error_Msg_N ("expression not allowed as source of move", Expr); + end if; return; end if; @@ -1195,7 +1272,7 @@ package body Sem_SPARK is begin Check_Parameter_Or_Global (Expr => Actual, - Typ => Underlying_Type (Etype (Formal)), + Typ => Retysp (Etype (Formal)), Kind => Ekind (Formal), Subp => Subp, Global_Var => False); @@ -1229,7 +1306,15 @@ package body Sem_SPARK is begin Inside_Procedure_Call := True; Check_Params (Call); - Check_Globals (Get_Called_Entity (Call)); + if Ekind (Get_Called_Entity (Call)) = E_Subprogram_Type then + if Emit_Messages then + Error_Msg_N + ("call through access to subprogram is not allowed in SPARK", + Call); + end if; + else + Check_Globals (Get_Called_Entity (Call)); + end if; Inside_Procedure_Call := False; Update_Params (Call); @@ -1260,6 +1345,17 @@ package body Sem_SPARK is Inside_Elaboration := False; + if Ekind (Spec_Id) = E_Function + and then Is_Anonymous_Access_Type (Etype (Spec_Id)) + and then not Is_Traversal_Function (Spec_Id) + then + if Emit_Messages then + Error_Msg_N ("anonymous access type for result only allowed for " + & "traversal functions", Spec_Id); + end if; + return; + end if; + -- Save environment and put a new one in place Move_Env (Current_Perm_Env, Saved_Env); @@ -1273,6 +1369,13 @@ package body Sem_SPARK is Setup_Globals (Spec_Id); end if; + -- For protected operations, add protected components to the environment + -- with adequate permissions. + + if Is_Protected_Operation (Spec_Id) then + Setup_Protected_Components (Spec_Id); + end if; + -- Analyze the body of the subprogram Check_List (Declarations (Body_N)); @@ -1316,9 +1419,37 @@ package body Sem_SPARK is Check_Expression (Subtype_Indication (Decl), Read); when N_Object_Declaration => + Expr := Expression (Decl); + Check_Type (Target_Typ); - Expr := Expression (Decl); + -- A declaration of a stand-alone object of an anonymous access + -- type shall have an explicit initial value and shall occur + -- immediately within a subprogram body, an entry body, or a + -- block statement (SPARK RM 3.10(4)). + + if Is_Anonymous_Access_Type (Target_Typ) then + declare + Scop : constant Entity_Id := Scope (Target); + begin + if not Is_Local_Context (Scop) then + if Emit_Messages then + Error_Msg_N + ("object of anonymous access type must be declared " + & "immediately within a subprogram, entry or block " + & "(SPARK RM 3.10(4))", Decl); + end if; + end if; + end; + + if No (Expr) then + if Emit_Messages then + Error_Msg_N ("object of anonymous access type must be " + & "initialized (SPARK RM 3.10(4))", Decl); + end if; + end if; + end if; + if Present (Expr) then Check_Assignment (Target => Target, Expr => Expr); @@ -1331,6 +1462,7 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => True, + Explanation => Decl, Permission => Read_Write, Children_Permission => Read_Write)); begin @@ -1375,13 +1507,22 @@ package body Sem_SPARK is -- Check_Expression -- ---------------------- - procedure Check_Expression (Expr : Node_Id; Mode : Checking_Mode) is - + procedure Check_Expression + (Expr : Node_Id; + Mode : Extended_Checking_Mode) + is -- Local subprograms function Is_Type_Name (Expr : Node_Id) return Boolean; -- Detect when a path expression is in fact a type name + procedure Move_Expression (Expr : Node_Id); + -- Some subexpressions are only analyzed in Move mode. This is a + -- specialized version of Check_Expression for that case. + + procedure Move_Expression_List (L : List_Id); + -- Call Move_Expression on every expression in the list L + procedure Read_Expression (Expr : Node_Id); -- Most subexpressions are only analyzed in Read mode. This is a -- specialized version of Check_Expression for that case. @@ -1390,7 +1531,6 @@ package body Sem_SPARK is -- Call Read_Expression on every expression in the list L procedure Read_Indexes (Expr : Node_Id); - pragma Precondition (Is_Path_Expression (Expr)); -- When processing a path, the index expressions and function call -- arguments occurring on the path should be analyzed in Read mode. @@ -1405,6 +1545,36 @@ package body Sem_SPARK is end Is_Type_Name; --------------------- + -- Move_Expression -- + --------------------- + + -- Distinguish the case where the argument is a path expression that + -- needs explicit moving. + + procedure Move_Expression (Expr : Node_Id) is + begin + if Is_Path_Expression (Expr) then + Check_Expression (Expr, Move); + else + Read_Expression (Expr); + end if; + end Move_Expression; + + -------------------------- + -- Move_Expression_List -- + -------------------------- + + procedure Move_Expression_List (L : List_Id) is + N : Node_Id; + begin + N := First (L); + while Present (N) loop + Move_Expression (N); + Next (N); + end loop; + end Move_Expression_List; + + --------------------- -- Read_Expression -- --------------------- @@ -1435,7 +1605,26 @@ package body Sem_SPARK is -- Local subprograms + function Is_Singleton_Choice (Choices : List_Id) return Boolean; + -- Return whether Choices is a singleton choice + procedure Read_Param (Formal : Entity_Id; Actual : Node_Id); + -- Call Read_Expression on the actual + + ------------------------- + -- Is_Singleton_Choice -- + ------------------------- + + function Is_Singleton_Choice (Choices : List_Id) return Boolean is + Choice : constant Node_Id := First (Choices); + begin + return List_Length (Choices) = 1 + and then Nkind (Choice) /= N_Others_Choice + and then not Nkind_In (Choice, N_Subtype_Indication, N_Range) + and then not + (Nkind_In (Choice, N_Identifier, N_Expanded_Name) + and then Is_Type (Entity (Choice))); + end Is_Singleton_Choice; ---------------- -- Read_Param -- @@ -1452,6 +1641,14 @@ package body Sem_SPARK is -- Start of processing for Read_Indexes begin + if not Is_Subpath_Expression (Expr) then + if Emit_Messages then + Error_Msg_N + ("name expected here for move/borrow/observe", Expr); + end if; + return; + end if; + case N_Subexpr'(Nkind (Expr)) is when N_Identifier | N_Expanded_Name @@ -1472,12 +1669,27 @@ package body Sem_SPARK is Read_Indexes (Prefix (Expr)); Read_Expression (Discrete_Range (Expr)); + -- The argument of an allocator is moved as part of the implicit + -- assignment. + when N_Allocator => - Read_Expression (Expression (Expr)); + Move_Expression (Expression (Expr)); when N_Function_Call => Read_Params (Expr); - Check_Globals (Get_Called_Entity (Expr)); + if Ekind (Get_Called_Entity (Expr)) = E_Subprogram_Type then + if Emit_Messages then + Error_Msg_N + ("call through access to subprogram is not allowed in " + & "SPARK", Expr); + end if; + else + Check_Globals (Get_Called_Entity (Expr)); + end if; + + when N_Op_Concat => + Read_Expression (Left_Opnd (Expr)); + Read_Expression (Right_Opnd (Expr)); when N_Qualified_Expression | N_Type_Conversion @@ -1485,6 +1697,142 @@ package body Sem_SPARK is => Read_Indexes (Expression (Expr)); + when N_Aggregate => + declare + Assocs : constant List_Id := Component_Associations (Expr); + CL : List_Id; + Assoc : Node_Id := Nlists.First (Assocs); + Choice : Node_Id; + + begin + -- The subexpressions of an aggregate are moved as part + -- of the implicit assignments. Handle the positional + -- components first. + + Move_Expression_List (Expressions (Expr)); + + -- Handle the named components next + + while Present (Assoc) loop + CL := Choices (Assoc); + + -- For an array aggregate, we should also check that the + -- expressions used in choices are readable. + + if Is_Array_Type (Etype (Expr)) then + Choice := Nlists.First (CL); + while Present (Choice) loop + if Nkind (Choice) /= N_Others_Choice then + Read_Expression (Choice); + end if; + Next (Choice); + end loop; + end if; + + -- There can be only one element for a value of deep type + -- in order to avoid aliasing. + + if not Box_Present (Assoc) + and then Is_Deep (Etype (Expression (Assoc))) + and then not Is_Singleton_Choice (CL) + and then Emit_Messages + then + Error_Msg_F + ("singleton choice required to prevent aliasing", + First (CL)); + end if; + + -- The subexpressions of an aggregate are moved as part + -- of the implicit assignments. + + if not Box_Present (Assoc) then + Move_Expression (Expression (Assoc)); + end if; + + Next (Assoc); + end loop; + end; + + when N_Extension_Aggregate => + declare + Exprs : constant List_Id := Expressions (Expr); + Assocs : constant List_Id := Component_Associations (Expr); + CL : List_Id; + Assoc : Node_Id := Nlists.First (Assocs); + + begin + Move_Expression (Ancestor_Part (Expr)); + + -- No positional components allowed at this stage + + if Present (Exprs) then + raise Program_Error; + end if; + + while Present (Assoc) loop + CL := Choices (Assoc); + + -- Only singleton components allowed at this stage + + if not Is_Singleton_Choice (CL) then + raise Program_Error; + end if; + + -- The subexpressions of an aggregate are moved as part + -- of the implicit assignments. + + if not Box_Present (Assoc) then + Move_Expression (Expression (Assoc)); + end if; + + Next (Assoc); + end loop; + end; + + when N_If_Expression => + declare + Cond : constant Node_Id := First (Expressions (Expr)); + Then_Part : constant Node_Id := Next (Cond); + Else_Part : constant Node_Id := Next (Then_Part); + begin + Read_Expression (Cond); + Read_Indexes (Then_Part); + Read_Indexes (Else_Part); + end; + + when N_Case_Expression => + declare + Cases : constant List_Id := Alternatives (Expr); + Cur_Case : Node_Id := First (Cases); + + begin + Read_Expression (Expression (Expr)); + + while Present (Cur_Case) loop + Read_Indexes (Expression (Cur_Case)); + Next (Cur_Case); + end loop; + end; + + when N_Attribute_Reference => + pragma Assert + (Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Loop_Entry + or else + Get_Attribute_Id (Attribute_Name (Expr)) = Attribute_Update + or else + Get_Attribute_Id (Attribute_Name (Expr)) = Attribute_Image); + + Read_Expression (Prefix (Expr)); + + if Get_Attribute_Id (Attribute_Name (Expr)) = Attribute_Update + or else (Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Image + and then Is_Type_Name (Prefix (Expr))) + then + Read_Expression_List (Expressions (Expr)); + end if; + when others => raise Program_Error; end case; @@ -1497,15 +1845,26 @@ package body Sem_SPARK is return; elsif Is_Path_Expression (Expr) then - Read_Indexes (Expr); - Process_Path (Expr, Mode); + if Mode /= Assign then + Read_Indexes (Expr); + end if; + + if Mode /= Read_Subexpr then + Process_Path (Expr, Mode); + end if; + return; end if; -- Expressions that are not path expressions should only be analyzed in -- Read mode. - pragma Assert (Mode = Read); + if Mode /= Read then + if Emit_Messages then + Error_Msg_N ("name expected here for move/borrow/observe", Expr); + end if; + return; + end if; -- Special handling for nodes that may contain evaluated expressions in -- the form of constraints. @@ -1539,6 +1898,20 @@ package body Sem_SPARK is end if; return; + when N_Digits_Constraint => + Read_Expression (Digits_Expression (Expr)); + if Present (Range_Constraint (Expr)) then + Read_Expression (Range_Constraint (Expr)); + end if; + return; + + when N_Delta_Constraint => + Read_Expression (Delta_Expression (Expr)); + if Present (Range_Constraint (Expr)) then + Read_Expression (Range_Constraint (Expr)); + end if; + return; + when others => null; end case; @@ -1548,12 +1921,28 @@ package body Sem_SPARK is case N_Subexpr'(Nkind (Expr)) is when N_Binary_Op - | N_Membership_Test | N_Short_Circuit => Read_Expression (Left_Opnd (Expr)); Read_Expression (Right_Opnd (Expr)); + when N_Membership_Test => + Read_Expression (Left_Opnd (Expr)); + if Present (Right_Opnd (Expr)) then + Read_Expression (Right_Opnd (Expr)); + else + declare + Cases : constant List_Id := Alternatives (Expr); + Cur_Case : Node_Id := First (Cases); + + begin + while Present (Cur_Case) loop + Read_Expression (Cur_Case); + Next (Cur_Case); + end loop; + end; + end if; + when N_Unary_Op => Read_Expression (Right_Opnd (Expr)); @@ -1637,6 +2026,14 @@ package body Sem_SPARK is when Attribute_Modulus => null; + -- The following attributes apply to types; there are no + -- expressions to read. + + when Attribute_Class + | Attribute_Storage_Size + => + null; + -- Postconditions should not be analyzed when Attribute_Old @@ -1645,8 +2042,7 @@ package body Sem_SPARK is raise Program_Error; when others => - Error_Msg_Name_1 := Aname; - Error_Msg_N ("attribute % not allowed in SPARK", Expr); + null; end case; end; @@ -1699,45 +2095,6 @@ package body Sem_SPARK is Read_Expression (Condition (Expr)); end; - when N_Aggregate => - declare - Assocs : constant List_Id := Component_Associations (Expr); - Assoc : Node_Id := First (Assocs); - CL : List_Id; - Choice : Node_Id; - - begin - while Present (Assoc) loop - - -- An array aggregate with a single component association - -- may have a nonstatic choice expression that needs to be - -- analyzed. This can only occur for a single choice that - -- is not the OTHERS one. - - if Is_Array_Type (Etype (Expr)) then - CL := Choices (Assoc); - if List_Length (CL) = 1 then - Choice := First (CL); - if Nkind (Choice) /= N_Others_Choice then - Read_Expression (Choice); - end if; - end if; - end if; - - -- The expression in the component association also needs to - -- be analyzed. - - Read_Expression (Expression (Assoc)); - Next (Assoc); - end loop; - - Read_Expression_List (Expressions (Expr)); - end; - - when N_Extension_Aggregate => - Read_Expression (Ancestor_Part (Expr)); - Read_Expression_List (Expressions (Expr)); - when N_Character_Literal | N_Numeric_Or_String_Literal | N_Operator_Symbol @@ -1749,7 +2106,7 @@ package body Sem_SPARK is when N_Delta_Aggregate | N_Target_Name => - Error_Msg_N ("unsupported construct in SPARK", Expr); + null; -- Procedure calls are handled in Check_Node @@ -1758,9 +2115,11 @@ package body Sem_SPARK is -- Path expressions are handled before this point - when N_Allocator + when N_Aggregate + | N_Allocator | N_Expanded_Name | N_Explicit_Dereference + | N_Extension_Aggregate | N_Function_Call | N_Identifier | N_Indexed_Component @@ -1819,7 +2178,8 @@ package body Sem_SPARK is (E : Entity_Id; Loop_Id : Node_Id; Perm : Perm_Kind; - Found_Perm : Perm_Kind); + Found_Perm : Perm_Kind; + Expl : Node_Id); -- A procedure that is called when the permissions found contradict -- the rules established by the RM at the exit of loops. This function -- is called with the entity, the node of the enclosing loop, the @@ -1889,14 +2249,15 @@ package body Sem_SPARK is begin if not (Permission (Tree) >= Perm) then Perm_Error_Loop_Exit - (E, Stmt, Permission (Tree), Perm); + (E, Stmt, Permission (Tree), Perm, Explanation (Tree)); end if; case Kind (Tree) is when Entire_Object => if not (Children_Permission (Tree) >= Perm) then Perm_Error_Loop_Exit - (E, Stmt, Children_Permission (Tree), Perm); + (E, Stmt, Children_Permission (Tree), Perm, + Explanation (Tree)); end if; @@ -1934,14 +2295,15 @@ package body Sem_SPARK is begin if not (Perm >= Permission (Tree)) then Perm_Error_Loop_Exit - (E, Stmt, Permission (Tree), Perm); + (E, Stmt, Permission (Tree), Perm, Explanation (Tree)); end if; case Kind (Tree) is when Entire_Object => if not (Perm >= Children_Permission (Tree)) then Perm_Error_Loop_Exit - (E, Stmt, Children_Permission (Tree), Perm); + (E, Stmt, Children_Permission (Tree), Perm, + Explanation (Tree)); end if; when Reference => @@ -1974,7 +2336,8 @@ package body Sem_SPARK is (E => E, Loop_Id => Stmt, Perm => Permission (New_Tree), - Found_Perm => Permission (Orig_Tree)); + Found_Perm => Permission (Orig_Tree), + Expl => Explanation (New_Tree)); end if; case Kind (New_Tree) is @@ -1994,7 +2357,8 @@ package body Sem_SPARK is Perm_Error_Loop_Exit (E, Stmt, Children_Permission (New_Tree), - Children_Permission (Orig_Tree)); + Children_Permission (Orig_Tree), + Explanation (New_Tree)); end if; when Reference => @@ -2073,16 +2437,16 @@ package body Sem_SPARK is KeyO := Perm_Tree_Maps.Get_First_Key (Component (Orig_Tree)); while KeyO.Present loop + CompN := Perm_Tree_Maps.Get + (Component (New_Tree), KeyO.K); + CompO := Perm_Tree_Maps.Get + (Component (Orig_Tree), KeyO.K); pragma Assert (CompO /= null); Check_Is_Less_Restrictive_Tree (CompN, CompO, E); KeyO := Perm_Tree_Maps.Get_Next_Key (Component (Orig_Tree)); - CompN := Perm_Tree_Maps.Get - (Component (New_Tree), KeyO.K); - CompO := Perm_Tree_Maps.Get - (Component (Orig_Tree), KeyO.K); end loop; end; @@ -2101,14 +2465,19 @@ package body Sem_SPARK is (E : Entity_Id; Loop_Id : Node_Id; Perm : Perm_Kind; - Found_Perm : Perm_Kind) + Found_Perm : Perm_Kind; + Expl : Node_Id) is begin - Error_Msg_Node_2 := Loop_Id; - Error_Msg_N ("insufficient permission for & when exiting loop &", E); - Perm_Mismatch (Exp_Perm => Perm, - Act_Perm => Found_Perm, - N => Loop_Id); + if Emit_Messages then + Error_Msg_Node_2 := Loop_Id; + Error_Msg_N + ("insufficient permission for & when exiting loop &", E); + Perm_Mismatch (Exp_Perm => Perm, + Act_Perm => Found_Perm, + N => Loop_Id, + Expl => Expl); + end if; end Perm_Error_Loop_Exit; -- Local variables @@ -2229,13 +2598,17 @@ package body Sem_SPARK is Check_Call_Statement (N); when N_Package_Body => - Check_Package_Body (N); + if not Is_Generic_Unit (Unique_Defining_Entity (N)) then + Check_Package_Body (N); + end if; when N_Subprogram_Body | N_Entry_Body | N_Task_Body => - Check_Callable_Body (N); + if not Is_Generic_Unit (Unique_Defining_Entity (N)) then + Check_Callable_Body (N); + end if; when N_Protected_Body => Check_List (Declarations (N)); @@ -2280,6 +2653,7 @@ package body Sem_SPARK is | N_Package_Instantiation | N_Package_Renaming_Declaration | N_Procedure_Instantiation + | N_Raise_xxx_Error | N_Record_Representation_Clause | N_Subprogram_Declaration | N_Subprogram_Renaming_Declaration @@ -2311,39 +2685,43 @@ package body Sem_SPARK is Save_In_Elab : constant Boolean := Inside_Elaboration; Spec : constant Node_Id := Package_Specification (Corresponding_Spec (Pack)); - Prag : constant Node_Id := SPARK_Pragma (Defining_Entity (Pack)); + Id : constant Entity_Id := Defining_Entity (Pack); + Prag : constant Node_Id := SPARK_Pragma (Id); + Aux_Prag : constant Node_Id := SPARK_Aux_Pragma (Id); Saved_Env : Perm_Env; begin - -- Only SPARK bodies are analyzed - - if No (Prag) - or else Get_SPARK_Mode_From_Annotation (Prag) /= Opt.On + if Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = Opt.On then - return; - end if; + Inside_Elaboration := True; - Inside_Elaboration := True; + -- Save environment and put a new one in place - -- Save environment and put a new one in place + Move_Env (Current_Perm_Env, Saved_Env); - Move_Env (Current_Perm_Env, Saved_Env); + -- Reanalyze package spec to have its variables in the environment - -- Reanalyze package spec to have its variables in the environment + Check_List (Visible_Declarations (Spec)); + Check_List (Private_Declarations (Spec)); - Check_List (Visible_Declarations (Spec)); - Check_List (Private_Declarations (Spec)); + -- Check declarations and statements in the special mode for + -- elaboration. - -- Check declarations and statements in the special mode for elaboration + Check_List (Declarations (Pack)); - Check_List (Declarations (Pack)); - Check_Node (Handled_Statement_Sequence (Pack)); + if Present (Aux_Prag) + and then Get_SPARK_Mode_From_Annotation (Aux_Prag) = Opt.On + then + Check_Node (Handled_Statement_Sequence (Pack)); + end if; - -- Restore the saved environment and free the current one + -- Restore the saved environment and free the current one - Move_Env (Saved_Env, Current_Perm_Env); + Move_Env (Saved_Env, Current_Perm_Env); - Inside_Elaboration := Save_In_Elab; + Inside_Elaboration := Save_In_Elab; + end if; end Check_Package_Body; ------------------------ @@ -2353,25 +2731,41 @@ package body Sem_SPARK is procedure Check_Package_Spec (Pack : Node_Id) is Save_In_Elab : constant Boolean := Inside_Elaboration; Spec : constant Node_Id := Specification (Pack); + Id : constant Entity_Id := Defining_Entity (Pack); + Prag : constant Node_Id := SPARK_Pragma (Id); + Aux_Prag : constant Node_Id := SPARK_Aux_Pragma (Id); Saved_Env : Perm_Env; begin - Inside_Elaboration := True; + if Present (Prag) + and then Get_SPARK_Mode_From_Annotation (Prag) = Opt.On + then + Inside_Elaboration := True; - -- Save environment and put a new one in place + -- Save environment and put a new one in place - Move_Env (Current_Perm_Env, Saved_Env); + Move_Env (Current_Perm_Env, Saved_Env); - -- Check declarations in the special mode for elaboration + -- Check declarations in the special mode for elaboration - Check_List (Visible_Declarations (Spec)); - Check_List (Private_Declarations (Spec)); + Check_List (Visible_Declarations (Spec)); - -- Restore the saved environment and free the current one + if Present (Aux_Prag) + and then Get_SPARK_Mode_From_Annotation (Aux_Prag) = Opt.On + then + Check_List (Private_Declarations (Spec)); + end if; - Move_Env (Saved_Env, Current_Perm_Env); + -- Restore the saved environment and free the current one. As part of + -- the restoration, the environment of the package spec is merged in + -- the enclosing environment, which may be an enclosing + -- package/subprogram spec or body which has access to the variables + -- of the package spec. - Inside_Elaboration := Save_In_Elab; + Merge_Env (Saved_Env, Current_Perm_Env); + + Inside_Elaboration := Save_In_Elab; + end if; end Check_Package_Spec; ------------------------------- @@ -2442,6 +2836,10 @@ package body Sem_SPARK is Mode := Move; end case; + if Mode = Assign then + Check_Expression (Expr, Read_Subexpr); + end if; + Check_Expression (Expr, Mode); end Check_Parameter_Or_Global; @@ -2458,7 +2856,7 @@ package body Sem_SPARK is Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag); Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag)); - Arg2 : Node_Id; + Arg2 : Node_Id := Empty; begin if Present (Arg1) then @@ -2478,9 +2876,14 @@ package body Sem_SPARK is -- independently for R permission. Outputs are checked -- independently to have RW permission on exit. - when Pragma_Contract_Cases + -- Postconditions are checked for correct use of 'Old, but starting + -- from the corresponding declaration, in order to avoid dealing with + -- with contracts on generic subprograms, which are not handled in + -- GNATprove. + + when Pragma_Precondition | Pragma_Postcondition - | Pragma_Precondition + | Pragma_Contract_Cases | Pragma_Refined_Post => null; @@ -2549,11 +2952,6 @@ package body Sem_SPARK is Reset (Current_Perm_Env); end Initialize; - -- Local variables - - Prag : Node_Id; - -- SPARK_Mode pragma in application - -- Start of processing for Check_Safe_Pointers begin @@ -2567,20 +2965,28 @@ package body Sem_SPARK is | N_Package_Declaration | N_Subprogram_Body => - Prag := SPARK_Pragma (Defining_Entity (N)); + declare + E : constant Entity_Id := Defining_Entity (N); + Prag : constant Node_Id := SPARK_Pragma (E); + -- SPARK_Mode pragma in application - if Present (Prag) then - if Get_SPARK_Mode_From_Annotation (Prag) = Opt.On then - Check_Node (N); - end if; + begin + if Ekind (Unique_Entity (E)) in Generic_Unit_Kind then + null; + + elsif Present (Prag) then + if Get_SPARK_Mode_From_Annotation (Prag) = Opt.On then + Check_Node (N); + end if; - elsif Nkind (N) = N_Package_Body then - Check_List (Declarations (N)); + elsif Nkind (N) = N_Package_Body then + Check_List (Declarations (N)); - elsif Nkind (N) = N_Package_Declaration then - Check_List (Private_Declarations (Specification (N))); - Check_List (Visible_Declarations (Specification (N))); - end if; + elsif Nkind (N) = N_Package_Declaration then + Check_List (Private_Declarations (Specification (N))); + Check_List (Visible_Declarations (Specification (N))); + end if; + end; when others => null; @@ -2613,17 +3019,20 @@ package body Sem_SPARK is -- function. if No (Root) then - if Nkind (Expr) = N_Function_Call then - Error_Msg_N - ("incorrect borrow or observe (SPARK RM 3.10(3))", Expr); - Error_Msg_N - ("\function called must be a traversal function", Expr); - else - Error_Msg_N - ("incorrect borrow or observe (SPARK RM 3.10(3))", Expr); - Error_Msg_N - ("\expression must be part of stand-alone object or parameter", - Expr); + if Emit_Messages then + if Nkind (Expr) = N_Function_Call then + Error_Msg_N + ("incorrect borrow or observe (SPARK RM 3.10(3))", Expr); + Error_Msg_N + ("\function called must be a traversal function", Expr); + else + Error_Msg_N + ("incorrect borrow or observe (SPARK RM 3.10(3))", Expr); + Error_Msg_N + ("\expression must be part of stand-alone object or " & + "parameter", + Expr); + end if; end if; Status := Error; @@ -2648,7 +3057,14 @@ package body Sem_SPARK is when N_Assignment_Statement => declare Target : constant Node_Id := Name (Stmt); + begin + -- Start with checking that the subexpressions of the target + -- path are readable, before possibly updating the permission + -- of these subexpressions in Check_Assignment. + + Check_Expression (Target, Read_Subexpr); + Check_Assignment (Target => Target, Expr => Expression (Stmt)); @@ -2661,7 +3077,9 @@ package body Sem_SPARK is if No (Get_Root_Object (Target, Through_Traversal => False)) then - Error_Msg_N ("illegal target for assignment", Target); + if Emit_Messages then + Error_Msg_N ("illegal target for assignment", Target); + end if; return; end if; @@ -2770,11 +3188,11 @@ package body Sem_SPARK is if Nkind (Expr) /= N_Null then declare Expr_Root : constant Entity_Id := - Get_Root_Object (Expr); + Get_Root_Object (Expr, Is_Traversal => True); Param : constant Entity_Id := First_Formal (Subp); begin - if Param /= Expr_Root then + if Param /= Expr_Root and then Emit_Messages then Error_Msg_NE ("returned value must be rooted in " & "traversed parameter & " @@ -2792,9 +3210,11 @@ package body Sem_SPARK is Check_Expression (Expr, Move); else - Error_Msg_N - ("expression not allowed as source of move", - Expr); + if Emit_Messages then + Error_Msg_N + ("expression not allowed as source of move", + Expr); + end if; return; end if; @@ -2817,14 +3237,14 @@ package body Sem_SPARK is Subp : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (Stmt)); Decls : constant List_Id := Return_Object_Declarations (Stmt); - Decl : constant Node_Id := Last (Decls); + Decl : constant Node_Id := Last_Non_Pragma (Decls); Obj : constant Entity_Id := Defining_Identifier (Decl); Perm : Perm_Kind; begin -- SPARK RM 3.10(5): return statement of traversal function - if Is_Traversal_Function (Subp) then + if Is_Traversal_Function (Subp) and then Emit_Messages then Error_Msg_N ("extended return cannot apply to a traversal function", Stmt); @@ -2833,10 +3253,13 @@ package body Sem_SPARK is Check_List (Return_Object_Declarations (Stmt)); Check_Node (Handled_Statement_Sequence (Stmt)); - Perm := Get_Perm (Obj); + if Is_Deep (Etype (Obj)) then + Perm := Get_Perm (Obj); - if Perm /= Read_Write then - Perm_Error (Decl, Read_Write, Perm); + if Perm /= Read_Write then + Perm_Error (Decl, Read_Write, Perm, + Expl => Get_Expl (Obj)); + end if; end if; if Ekind_In (Subp, E_Procedure, E_Entry) @@ -2954,7 +3377,7 @@ package body Sem_SPARK is | N_Selective_Accept | N_Timed_Entry_Call => - Error_Msg_N ("unsupported construct in SPARK", Stmt); + null; -- The following nodes are never generated in GNATprove mode @@ -2970,12 +3393,12 @@ package body Sem_SPARK is ---------------- procedure Check_Type (Typ : Entity_Id) is - Check_Typ : constant Entity_Id := Underlying_Type (Typ); + Check_Typ : constant Entity_Id := Retysp (Typ); begin case Type_Kind'(Ekind (Check_Typ)) is when Access_Kind => - case Access_Kind'(Ekind (Underlying_Type (Check_Typ))) is + case Access_Kind'(Ekind (Check_Typ)) is when E_Access_Type | E_Anonymous_Access_Type => @@ -2983,18 +3406,26 @@ package body Sem_SPARK is when E_Access_Subtype => Check_Type (Base_Type (Check_Typ)); when E_Access_Attribute_Type => - Error_Msg_N ("access attribute not allowed in SPARK", - Check_Typ); + if Emit_Messages then + Error_Msg_N ("access attribute not allowed in SPARK", + Check_Typ); + end if; when E_Allocator_Type => - Error_Msg_N ("missing type resolution", Check_Typ); + if Emit_Messages then + Error_Msg_N ("missing type resolution", Check_Typ); + end if; when E_General_Access_Type => - Error_Msg_NE - ("general access type & not allowed in SPARK", - Check_Typ, Check_Typ); + if Emit_Messages then + Error_Msg_NE + ("general access type & not allowed in SPARK", + Check_Typ, Check_Typ); + end if; when Access_Subprogram_Kind => - Error_Msg_NE - ("access to subprogram type & not allowed in SPARK", - Check_Typ, Check_Typ); + if Emit_Messages then + Error_Msg_NE + ("access to subprogram type & not allowed in SPARK", + Check_Typ, Check_Typ); + end if; end case; when E_Array_Type @@ -3007,9 +3438,11 @@ package body Sem_SPARK is and then (Is_Tagged_Type (Check_Typ) or else Is_Class_Wide_Type (Check_Typ)) then - Error_Msg_NE - ("tagged type & cannot be owning in SPARK", - Check_Typ, Check_Typ); + if Emit_Messages then + Error_Msg_NE + ("tagged type & cannot be owning in SPARK", + Check_Typ, Check_Typ); + end if; else declare @@ -3017,7 +3450,12 @@ package body Sem_SPARK is begin Comp := First_Component_Or_Discriminant (Check_Typ); while Present (Comp) loop - Check_Type (Etype (Comp)); + + -- Ignore components which are not visible in SPARK + + if Component_Is_Visible_In_SPARK (Comp) then + Check_Type (Etype (Comp)); + end if; Next_Component_Or_Discriminant (Comp); end loop; end; @@ -3033,17 +3471,62 @@ package body Sem_SPARK is => null; - -- The following should not arise as underlying types + -- Do not check type whose full view is not SPARK when E_Private_Type | E_Private_Subtype | E_Limited_Private_Type | E_Limited_Private_Subtype => - raise Program_Error; + null; end case; end Check_Type; + -------------- + -- Get_Expl -- + -------------- + + function Get_Expl (N : Node_Or_Entity_Id) return Node_Id is + begin + -- Special case for the object declared in an extended return statement + + if Nkind (N) = N_Defining_Identifier then + declare + C : constant Perm_Tree_Access := + Get (Current_Perm_Env, Unique_Entity (N)); + begin + pragma Assert (C /= null); + return Explanation (C); + end; + + -- The expression is a call to a traversal function + + elsif Is_Traversal_Function_Call (N) then + return N; + + -- The expression is directly rooted in an object + + elsif Present (Get_Root_Object (N, Through_Traversal => False)) then + declare + Tree_Or_Perm : constant Perm_Or_Tree := Get_Perm_Or_Tree (N); + begin + case Tree_Or_Perm.R is + when Folded => + return Tree_Or_Perm.Explanation; + + when Unfolded => + pragma Assert (Tree_Or_Perm.Tree_Access /= null); + return Explanation (Tree_Or_Perm.Tree_Access); + end case; + end; + + -- The expression is a function call, an allocation, or null + + else + return N; + end if; + end Get_Expl; + ----------------------------------- -- Get_Observed_Or_Borrowed_Expr -- ----------------------------------- @@ -3125,11 +3608,20 @@ package body Sem_SPARK is C : constant Perm_Tree_Access := Get (Current_Perm_Env, Unique_Entity (Entity (N))); begin - pragma Assert (C /= null); + -- Except during elaboration, the root object should have been + -- declared and entered into the current permission + -- environment. + + if not Inside_Elaboration + and then C = null + then + Illegal_Global_Usage (N, N); + end if; + return (R => Unfolded, Tree_Access => C); end; - -- For a non-terminal path, we get the permission tree of its + -- For a nonterminal path, we get the permission tree of its -- prefix, and then get the subtree associated with the extension, -- if unfolded. If folded, we return the permission associated with -- children. @@ -3159,7 +3651,9 @@ package body Sem_SPARK is when Entire_Object => return (R => Folded, Found_Permission => - Children_Permission (C.Tree_Access)); + Children_Permission (C.Tree_Access), + Explanation => + Explanation (C.Tree_Access)); when Reference => pragma Assert (Nkind (N) = N_Explicit_Dereference); @@ -3170,7 +3664,8 @@ package body Sem_SPARK is pragma Assert (Nkind (N) = N_Selected_Component); declare Comp : constant Entity_Id := - Entity (Selector_Name (N)); + Original_Record_Component + (Entity (Selector_Name (N))); D : constant Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C.Tree_Access), Comp); @@ -3208,7 +3703,7 @@ package body Sem_SPARK is function Get_Perm_Tree (N : Node_Id) return Perm_Tree_Access is begin - return Set_Perm_Prefixes (N, None); + return Set_Perm_Prefixes (N, None, Empty); end Get_Perm_Tree; --------------------- @@ -3217,9 +3712,37 @@ package body Sem_SPARK is function Get_Root_Object (Expr : Node_Id; - Through_Traversal : Boolean := True) return Entity_Id + Through_Traversal : Boolean := True; + Is_Traversal : Boolean := False) return Entity_Id is + function GRO (Expr : Node_Id) return Entity_Id; + -- Local wrapper on the actual function, to propagate the values of + -- optional parameters. + + --------- + -- GRO -- + --------- + + function GRO (Expr : Node_Id) return Entity_Id is + begin + return Get_Root_Object (Expr, Through_Traversal, Is_Traversal); + end GRO; + + Get_Root_Object : Boolean; + pragma Unmodified (Get_Root_Object); + -- Local variable to mask the name of function Get_Root_Object, to + -- prevent direct call. Instead GRO wrapper should be called. + + -- Start of processing for Get_Root_Object + begin + if not Is_Subpath_Expression (Expr, Is_Traversal) then + if Emit_Messages then + Error_Msg_N ("name expected here for path", Expr); + end if; + return Empty; + end if; + case Nkind (Expr) is when N_Expanded_Name | N_Identifier @@ -3231,12 +3754,16 @@ package body Sem_SPARK is | N_Selected_Component | N_Slice => - return Get_Root_Object (Prefix (Expr), Through_Traversal); + return GRO (Prefix (Expr)); - -- There is no root object for an allocator or NULL + -- There is no root object for an (extension) aggregate, allocator, + -- concat, or NULL. - when N_Allocator + when N_Aggregate + | N_Allocator + | N_Extension_Aggregate | N_Null + | N_Op_Concat => return Empty; @@ -3248,7 +3775,7 @@ package body Sem_SPARK is if Through_Traversal and then Is_Traversal_Function_Call (Expr) then - return Get_Root_Object (First_Actual (Expr), Through_Traversal); + return GRO (First_Actual (Expr)); else return Empty; end if; @@ -3257,7 +3784,81 @@ package body Sem_SPARK is | N_Type_Conversion | N_Unchecked_Type_Conversion => - return Get_Root_Object (Expression (Expr), Through_Traversal); + return GRO (Expression (Expr)); + + when N_Attribute_Reference => + pragma Assert + (Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Loop_Entry + or else + Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Update + or else Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Image); + return Empty; + + when N_If_Expression => + if Is_Traversal then + declare + Cond : constant Node_Id := First (Expressions (Expr)); + Then_Part : constant Node_Id := Next (Cond); + Else_Part : constant Node_Id := Next (Then_Part); + Then_Root : constant Entity_Id := GRO (Then_Part); + Else_Root : constant Entity_Id := GRO (Else_Part); + begin + if Nkind (Then_Part) = N_Null then + return Else_Root; + elsif Nkind (Else_Part) = N_Null then + return Then_Part; + elsif Then_Root = Else_Root then + return Then_Root; + else + if Emit_Messages then + Error_Msg_N + ("same name expected here in each branch", Expr); + end if; + return Empty; + end if; + end; + else + if Emit_Messages then + Error_Msg_N ("name expected here for path", Expr); + end if; + return Empty; + end if; + + when N_Case_Expression => + if Is_Traversal then + declare + Cases : constant List_Id := Alternatives (Expr); + Cur_Case : Node_Id := First (Cases); + Cur_Root : Entity_Id; + Common_Root : Entity_Id := Empty; + + begin + while Present (Cur_Case) loop + Cur_Root := GRO (Expression (Cur_Case)); + + if Common_Root = Empty then + Common_Root := Cur_Root; + elsif Common_Root /= Cur_Root then + if Emit_Messages then + Error_Msg_N + ("same name expected here in each branch", Expr); + end if; + return Empty; + end if; + Next (Cur_Case); + end loop; + + return Common_Root; + end; + else + if Emit_Messages then + Error_Msg_N ("name expected here for path", Expr); + end if; + return Empty; + end if; when others => raise Program_Error; @@ -3360,9 +3961,10 @@ package body Sem_SPARK is -- Illegal_Global_Usage -- -------------------------- - procedure Illegal_Global_Usage (N : Node_Or_Entity_Id) is + procedure Illegal_Global_Usage (N : Node_Or_Entity_Id; E : Entity_Id) + is begin - Error_Msg_NE ("cannot use global variable & of deep type", N, N); + Error_Msg_NE ("cannot use global variable & of deep type", N, E); Error_Msg_N ("\without prior declaration in a Global aspect", N); Errout.Finalize (Last_Call => True); Errout.Output_Messages; @@ -3375,22 +3977,27 @@ package body Sem_SPARK is function Is_Deep (Typ : Entity_Id) return Boolean is begin - case Type_Kind'(Ekind (Underlying_Type (Typ))) is + case Type_Kind'(Ekind (Retysp (Typ))) is when Access_Kind => return True; when E_Array_Type | E_Array_Subtype => - return Is_Deep (Component_Type (Typ)); + return Is_Deep (Component_Type (Retysp (Typ))); when Record_Kind => declare Comp : Entity_Id; begin - Comp := First_Component_Or_Discriminant (Typ); + Comp := First_Component_Or_Discriminant (Retysp (Typ)); while Present (Comp) loop - if Is_Deep (Etype (Comp)) then + + -- Ignore components not visible in SPARK + + if Component_Is_Visible_In_SPARK (Comp) + and then Is_Deep (Etype (Comp)) + then return True; end if; Next_Component_Or_Discriminant (Comp); @@ -3408,22 +4015,55 @@ package body Sem_SPARK is => return False; - -- The following should not arise as underlying types + -- Ignore full view of types if it is not in SPARK when E_Private_Type | E_Private_Subtype | E_Limited_Private_Type | E_Limited_Private_Subtype => - raise Program_Error; + return False; end case; end Is_Deep; + ---------------------- + -- Is_Local_Context -- + ---------------------- + + function Is_Local_Context (Scop : Entity_Id) return Boolean is + begin + return Is_Subprogram_Or_Entry (Scop) + or else Ekind (Scop) = E_Block; + end Is_Local_Context; + ------------------------ -- Is_Path_Expression -- ------------------------ - function Is_Path_Expression (Expr : Node_Id) return Boolean is + function Is_Path_Expression + (Expr : Node_Id; + Is_Traversal : Boolean := False) return Boolean + is + function IPE (Expr : Node_Id) return Boolean; + -- Local wrapper on the actual function, to propagate the values of + -- optional parameter Is_Traversal. + + --------- + -- IPE -- + --------- + + function IPE (Expr : Node_Id) return Boolean is + begin + return Is_Path_Expression (Expr, Is_Traversal); + end IPE; + + Is_Path_Expression : Boolean; + pragma Unmodified (Is_Path_Expression); + -- Local variable to mask the name of function Is_Path_Expression, to + -- prevent direct call. Instead IPE wrapper should be called. + + -- Start of processing for Is_Path_Expression + begin case Nkind (Expr) is when N_Expanded_Name @@ -3440,10 +4080,12 @@ package body Sem_SPARK is when N_Null => return True; - -- Object returned by a allocator or function call corresponds to - -- a path. + -- Object returned by an (extension) aggregate, an allocator, or + -- a function call corresponds to a path. - when N_Allocator + when N_Aggregate + | N_Allocator + | N_Extension_Aggregate | N_Function_Call => return True; @@ -3452,7 +4094,47 @@ package body Sem_SPARK is | N_Type_Conversion | N_Unchecked_Type_Conversion => - return Is_Path_Expression (Expression (Expr)); + return IPE (Expression (Expr)); + + -- When returning from a traversal function, consider an + -- if-expression as a possible path expression. + + when N_If_Expression => + if Is_Traversal then + declare + Cond : constant Node_Id := First (Expressions (Expr)); + Then_Part : constant Node_Id := Next (Cond); + Else_Part : constant Node_Id := Next (Then_Part); + begin + return IPE (Then_Part) + and then IPE (Else_Part); + end; + else + return False; + end if; + + -- When returning from a traversal function, consider + -- a case-expression as a possible path expression. + + when N_Case_Expression => + if Is_Traversal then + declare + Cases : constant List_Id := Alternatives (Expr); + Cur_Case : Node_Id := First (Cases); + + begin + while Present (Cur_Case) loop + if not IPE (Expression (Cur_Case)) then + return False; + end if; + Next (Cur_Case); + end loop; + + return True; + end; + else + return False; + end if; when others => return False; @@ -3533,8 +4215,10 @@ package body Sem_SPARK is when N_Selected_Component => if Nkind (Expr_Elt) /= N_Selected_Component - or else Entity (Selector_Name (Prefix_Elt)) - /= Entity (Selector_Name (Expr_Elt)) + or else Original_Record_Component + (Entity (Selector_Name (Prefix_Elt))) + /= Original_Record_Component + (Entity (Selector_Name (Expr_Elt))) then return False; end if; @@ -3573,6 +4257,29 @@ package body Sem_SPARK is end Is_Prefix_Or_Almost; --------------------------- + -- Is_Subpath_Expression -- + --------------------------- + + function Is_Subpath_Expression + (Expr : Node_Id; + Is_Traversal : Boolean := False) return Boolean + is + begin + return Is_Path_Expression (Expr, Is_Traversal) + or else (Nkind (Expr) = N_Attribute_Reference + and then + (Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Update + or else + Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Loop_Entry + or else + Get_Attribute_Id (Attribute_Name (Expr)) = + Attribute_Image)) + or else Nkind (Expr) = N_Op_Concat; + end Is_Subpath_Expression; + + --------------------------- -- Is_Traversal_Function -- --------------------------- @@ -3591,7 +4298,7 @@ package body Sem_SPARK is -- and the function's first parameter is of an access type. - and then Is_Access_Type (Etype (First_Formal (E))); + and then Is_Access_Type (Retysp (Etype (First_Formal (E)))); end Is_Traversal_Function; -------------------------------- @@ -3912,6 +4619,7 @@ package body Sem_SPARK is (N : Node_Id; Perm : Perm_Kind; Found_Perm : Perm_Kind; + Expl : Node_Id; Forbidden_Perm : Boolean := False) is procedure Set_Root_Object @@ -3968,14 +4676,16 @@ package body Sem_SPARK is begin Set_Root_Object (N, Root, Is_Deref); - if Is_Deref then - Error_Msg_NE - ("insufficient permission on dereference from &", N, Root); - else - Error_Msg_NE ("insufficient permission for &", N, Root); - end if; + if Emit_Messages then + if Is_Deref then + Error_Msg_NE + ("insufficient permission on dereference from &", N, Root); + else + Error_Msg_NE ("insufficient permission for &", N, Root); + end if; - Perm_Mismatch (N, Perm, Found_Perm, Forbidden_Perm); + Perm_Mismatch (N, Perm, Found_Perm, Expl, Forbidden_Perm); + end if; end Perm_Error; ------------------------------- @@ -3986,13 +4696,16 @@ package body Sem_SPARK is (E : Entity_Id; Subp : Entity_Id; Perm : Perm_Kind; - Found_Perm : Perm_Kind) + Found_Perm : Perm_Kind; + Expl : Node_Id) is begin - Error_Msg_Node_2 := Subp; - Error_Msg_NE ("insufficient permission for & when returning from &", - Subp, E); - Perm_Mismatch (Subp, Perm, Found_Perm); + if Emit_Messages then + Error_Msg_Node_2 := Subp; + Error_Msg_NE ("insufficient permission for & when returning from &", + Subp, E); + Perm_Mismatch (Subp, Perm, Found_Perm, Expl); + end if; end Perm_Error_Subprogram_End; ------------------ @@ -4033,9 +4746,11 @@ package body Sem_SPARK is Var := Key.K; Borrowed := Get (Current_Borrowers, Var); - if Is_Prefix_Or_Almost (Pref => Borrowed, Expr => Expr) then + if Is_Prefix_Or_Almost (Pref => Borrowed, Expr => Expr) + and then Emit_Messages + then Error_Msg_Sloc := Sloc (Borrowed); - Error_Msg_N ("expression was borrowed #", Expr); + Error_Msg_N ("object was borrowed #", Expr); end if; Key := Get_Next_Key (Current_Borrowers); @@ -4069,9 +4784,11 @@ package body Sem_SPARK is Var := Key.K; Observed := Get (Current_Observers, Var); - if Is_Prefix_Or_Almost (Pref => Observed, Expr => Expr) then + if Is_Prefix_Or_Almost (Pref => Observed, Expr => Expr) + and then Emit_Messages + then Error_Msg_Sloc := Sloc (Observed); - Error_Msg_N ("expression was observed #", Expr); + Error_Msg_N ("object was observed #", Expr); end if; Key := Get_Next_Key (Current_Observers); @@ -4107,7 +4824,7 @@ package body Sem_SPARK is if not Inside_Elaboration and then Get (Current_Perm_Env, Root) = null then - Illegal_Global_Usage (Expr); + Illegal_Global_Usage (Expr, Root); end if; -- During elaboration, only the validity of operations is checked, no @@ -4134,7 +4851,7 @@ package body Sem_SPARK is -- Check path is readable if Perm not in Read_Perm then - Perm_Error (Expr, Read_Only, Perm); + Perm_Error (Expr, Read_Only, Perm, Expl => Get_Expl (Expr)); return; end if; @@ -4147,6 +4864,7 @@ package body Sem_SPARK is if Is_Deep (Expr_Type) and then not Inside_Procedure_Call and then Present (Get_Root_Object (Expr)) + and then Emit_Messages then Error_Msg_N ("illegal move during elaboration", Expr); end if; @@ -4158,7 +4876,7 @@ package body Sem_SPARK is if not Is_Deep (Expr_Type) then if Perm not in Read_Perm then - Perm_Error (Expr, Read_Only, Perm); + Perm_Error (Expr, Read_Only, Perm, Expl => Get_Expl (Expr)); end if; return; end if; @@ -4167,7 +4885,7 @@ package body Sem_SPARK is -- the source object (if any) shall be Unrestricted. if Perm /= Read_Write then - Perm_Error (Expr, Read_Write, Perm); + Perm_Error (Expr, Read_Write, Perm, Expl => Get_Expl (Expr)); return; end if; @@ -4182,45 +4900,39 @@ package body Sem_SPARK is -- For assignment, check W permission if Perm not in Write_Perm then - Perm_Error (Expr, Write_Only, Perm); + Perm_Error (Expr, Write_Only, Perm, Expl => Get_Expl (Expr)); return; end if; when Borrow => - -- Forbidden during elaboration + -- Forbidden during elaboration, an error is already issued in + -- Check_Declaration, just return. if Inside_Elaboration then - if not Inside_Procedure_Call then - Error_Msg_N ("illegal borrow during elaboration", Expr); - end if; - return; end if; -- For borrowing, check RW permission if Perm /= Read_Write then - Perm_Error (Expr, Read_Write, Perm); + Perm_Error (Expr, Read_Write, Perm, Expl => Get_Expl (Expr)); return; end if; when Observe => - -- Forbidden during elaboration + -- Forbidden during elaboration, an error is already issued in + -- Check_Declaration, just return. if Inside_Elaboration then - if not Inside_Procedure_Call then - Error_Msg_N ("illegal observe during elaboration", Expr); - end if; - return; end if; -- For borrowing, check R permission if Perm not in Read_Perm then - Perm_Error (Expr, Read_Only, Perm); + Perm_Error (Expr, Read_Only, Perm, Expl => Get_Expl (Expr)); return; end if; end case; @@ -4259,10 +4971,10 @@ package body Sem_SPARK is if Present (Get_Root_Object (Expr)) then declare Tree : constant Perm_Tree_Access := - Set_Perm_Prefixes (Expr, Write_Only); + Set_Perm_Prefixes (Expr, Write_Only, Expl => Expr); begin pragma Assert (Tree /= null); - Set_Perm_Extensions_Move (Tree, Etype (Expr)); + Set_Perm_Extensions_Move (Tree, Etype (Expr), Expl => Expr); end; end if; @@ -4283,7 +4995,7 @@ package body Sem_SPARK is Tree : constant Perm_Tree_Access := Get_Perm_Tree (Expr); begin Tree.all.Tree.Permission := Read_Write; - Set_Perm_Extensions (Tree, Read_Write); + Set_Perm_Extensions (Tree, Read_Write, Expl => Expr); -- Normalize the permission tree @@ -4390,7 +5102,8 @@ package body Sem_SPARK is (E => Id, Subp => Subp, Perm => Read_Write, - Found_Perm => Permission (Tree)); + Found_Perm => Permission (Tree), + Expl => Explanation (Tree)); end if; end; end Return_Parameter_Or_Global; @@ -4406,7 +5119,7 @@ package body Sem_SPARK is while Present (Formal) loop Return_Parameter_Or_Global (Id => Formal, - Typ => Underlying_Type (Etype (Formal)), + Typ => Retysp (Etype (Formal)), Kind => Ekind (Formal), Subp => Subp, Global_Var => False); @@ -4418,7 +5131,10 @@ package body Sem_SPARK is -- Set_Perm_Extensions -- ------------------------- - procedure Set_Perm_Extensions (T : Perm_Tree_Access; P : Perm_Kind) is + procedure Set_Perm_Extensions + (T : Perm_Tree_Access; + P : Perm_Kind; + Expl : Node_Id) is procedure Free_Perm_Tree_Children (T : Perm_Tree_Access); -- Free the permission tree of children if any, prio to replacing T @@ -4462,6 +5178,7 @@ package body Sem_SPARK is Free_Perm_Tree_Children (T); T.all.Tree := Perm_Tree'(Kind => Entire_Object, Is_Node_Deep => Is_Node_Deep (T), + Explanation => Expl, Permission => Permission (T), Children_Permission => P); end Set_Perm_Extensions; @@ -4471,14 +5188,16 @@ package body Sem_SPARK is ------------------------------ procedure Set_Perm_Extensions_Move - (T : Perm_Tree_Access; - E : Entity_Id) + (T : Perm_Tree_Access; + E : Entity_Id; + Expl : Node_Id) is + Check_Ty : constant Entity_Id := Retysp (E); begin -- Shallow extensions are set to RW if not Is_Node_Deep (T) then - Set_Perm_Extensions (T, Read_Write); + Set_Perm_Extensions (T, Read_Write, Expl => Expl); return; end if; @@ -4492,7 +5211,7 @@ package body Sem_SPARK is -- precision. when Entire_Object => - case Ekind (E) is + case Ekind (Check_Ty) is when E_Array_Type | E_Array_Subtype => @@ -4502,12 +5221,15 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Node_Deep (T), + Explanation => Expl, Permission => Read_Write, Children_Permission => Read_Write)); begin - Set_Perm_Extensions_Move (C, Component_Type (E)); + Set_Perm_Extensions_Move + (C, Component_Type (Check_Ty), Expl); T.all.Tree := (Kind => Array_Component, Is_Node_Deep => Is_Node_Deep (T), + Explanation => Expl, Permission => Write_Only, Get_Elem => C); end; @@ -4519,22 +5241,43 @@ package body Sem_SPARK is Hashtbl : Perm_Tree_Maps.Instance; begin - Comp := First_Component_Or_Discriminant (E); + Comp := First_Component_Or_Discriminant (Check_Ty); while Present (Comp) loop - C := new Perm_Tree_Wrapper' - (Tree => - (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Comp)), - Permission => Read_Write, - Children_Permission => Read_Write)); - Set_Perm_Extensions_Move (C, Etype (Comp)); - Perm_Tree_Maps.Set (Hashtbl, Comp, C); + + -- Unfold components which are visible in SPARK + + if Component_Is_Visible_In_SPARK (Comp) then + C := new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => Is_Deep (Etype (Comp)), + Explanation => Expl, + Permission => Read_Write, + Children_Permission => Read_Write)); + Set_Perm_Extensions_Move (C, Etype (Comp), Expl); + + -- Hidden components are never deep + + else + C := new Perm_Tree_Wrapper' + (Tree => + (Kind => Entire_Object, + Is_Node_Deep => False, + Explanation => Expl, + Permission => Read_Write, + Children_Permission => Read_Write)); + Set_Perm_Extensions (C, Read_Write, Expl => Expl); + end if; + + Perm_Tree_Maps.Set + (Hashtbl, Original_Record_Component (Comp), C); Next_Component_Or_Discriminant (Comp); end loop; T.all.Tree := (Kind => Record_Component, Is_Node_Deep => Is_Node_Deep (T), + Explanation => Expl, Permission => Write_Only, Component => Hashtbl); end; @@ -4542,14 +5285,15 @@ package body Sem_SPARK is -- Otherwise, extensions are set to NO when others => - Set_Perm_Extensions (T, No_Access); + Set_Perm_Extensions (T, No_Access, Expl); end case; when Reference => - Set_Perm_Extensions (T, No_Access); + Set_Perm_Extensions (T, No_Access, Expl); when Array_Component => - Set_Perm_Extensions_Move (Get_Elem (T), Component_Type (E)); + Set_Perm_Extensions_Move + (Get_Elem (T), Component_Type (Check_Ty), Expl); when Record_Component => declare @@ -4557,11 +5301,23 @@ package body Sem_SPARK is Comp : Entity_Id; begin - Comp := First_Component_Or_Discriminant (E); + Comp := First_Component_Or_Discriminant (Check_Ty); while Present (Comp) loop - C := Perm_Tree_Maps.Get (Component (T), Comp); + C := Perm_Tree_Maps.Get + (Component (T), Original_Record_Component (Comp)); pragma Assert (C /= null); - Set_Perm_Extensions_Move (C, Etype (Comp)); + + -- Move visible components + + if Component_Is_Visible_In_SPARK (Comp) then + Set_Perm_Extensions_Move (C, Etype (Comp), Expl); + + -- Hidden components are never deep + + else + Set_Perm_Extensions (C, Read_Write, Expl => Expl); + end if; + Next_Component_Or_Discriminant (Comp); end loop; end; @@ -4574,7 +5330,8 @@ package body Sem_SPARK is function Set_Perm_Prefixes (N : Node_Id; - Perm : Perm_Kind_Option) return Perm_Tree_Access + Perm : Perm_Kind_Option; + Expl : Node_Id) return Perm_Tree_Access is begin case Nkind (N) is @@ -4594,7 +5351,7 @@ package body Sem_SPARK is return C; end; - -- For a non-terminal path, we set the permission tree of its prefix, + -- For a nonterminal path, we set the permission tree of its prefix, -- and then we extract from the returned pointer the subtree and -- assign an adequate permission to it, if unfolded. If folded, -- we unroll the tree one level. @@ -4602,7 +5359,7 @@ package body Sem_SPARK is when N_Explicit_Dereference => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes (Prefix (N), Perm); + Set_Perm_Prefixes (Prefix (N), Perm, Expl); pragma Assert (C /= null); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Reference); @@ -4635,6 +5392,7 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (N)), + Explanation => Expl, Permission => Child_P, Children_Permission => Child_P)); begin @@ -4644,6 +5402,7 @@ package body Sem_SPARK is C.all.Tree := (Kind => Reference, Is_Node_Deep => Is_Node_Deep (C), + Explanation => Expl, Permission => Permission (C), Get_All => D); return D; @@ -4654,7 +5413,7 @@ package body Sem_SPARK is when N_Selected_Component => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes (Prefix (N), Perm); + Set_Perm_Prefixes (Prefix (N), Perm, Expl); pragma Assert (C /= null); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Record_Component); @@ -4664,7 +5423,9 @@ package body Sem_SPARK is if Kind (C) = Record_Component then declare - Comp : constant Entity_Id := Entity (Selector_Name (N)); + Comp : constant Entity_Id := + Original_Record_Component + (Entity (Selector_Name (N))); D : constant Perm_Tree_Access := Perm_Tree_Maps.Get (Component (C), Comp); pragma Assert (D /= null); @@ -4693,11 +5454,14 @@ package body Sem_SPARK is begin Comp := - First_Component_Or_Discriminant (Etype (Prefix (N))); + First_Component_Or_Discriminant + (Retysp (Etype (Prefix (N)))); while Present (Comp) loop if Perm /= None - and then Comp = Entity (Selector_Name (N)) + and then Original_Record_Component (Comp) = + Original_Record_Component + (Entity (Selector_Name (N))) then P := Perm; else @@ -4707,14 +5471,22 @@ package body Sem_SPARK is D := new Perm_Tree_Wrapper' (Tree => (Kind => Entire_Object, - Is_Node_Deep => Is_Deep (Etype (Comp)), + Is_Node_Deep => + -- Hidden components are never deep + Component_Is_Visible_In_SPARK (Comp) + and then Is_Deep (Etype (Comp)), + Explanation => Expl, Permission => P, Children_Permission => Child_P)); - Perm_Tree_Maps.Set (Hashtbl, Comp, D); + Perm_Tree_Maps.Set + (Hashtbl, Original_Record_Component (Comp), D); -- Store the tree to return for this component - if Comp = Entity (Selector_Name (N)) then + if Original_Record_Component (Comp) = + Original_Record_Component + (Entity (Selector_Name (N))) + then D_This := D; end if; @@ -4723,6 +5495,7 @@ package body Sem_SPARK is C.all.Tree := (Kind => Record_Component, Is_Node_Deep => Is_Node_Deep (C), + Explanation => Expl, Permission => Permission (C), Component => Hashtbl); return D_This; @@ -4735,7 +5508,7 @@ package body Sem_SPARK is => declare C : constant Perm_Tree_Access := - Set_Perm_Prefixes (Prefix (N), Perm); + Set_Perm_Prefixes (Prefix (N), Perm, Expl); pragma Assert (C /= null); pragma Assert (Kind (C) = Entire_Object or else Kind (C) = Array_Component); @@ -4768,6 +5541,7 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Node_Deep (C), + Explanation => Expl, Permission => Child_P, Children_Permission => Child_P)); begin @@ -4777,6 +5551,7 @@ package body Sem_SPARK is C.all.Tree := (Kind => Array_Component, Is_Node_Deep => Is_Node_Deep (C), + Explanation => Expl, Permission => Permission (C), Get_Elem => D); return D; @@ -4788,7 +5563,7 @@ package body Sem_SPARK is | N_Type_Conversion | N_Unchecked_Type_Conversion => - return Set_Perm_Prefixes (Expression (N), Perm); + return Set_Perm_Prefixes (Expression (N), Perm, Expl); when others => raise Program_Error; @@ -4893,7 +5668,8 @@ package body Sem_SPARK is Typ => Typ, Kind => Kind, Subp => Subp, - Global_Var => Global_Var); + Global_Var => Global_Var, + Expl => Expr); end Setup_Global; procedure Setup_Globals_Inst is new Handle_Globals (Setup_Global); @@ -4913,7 +5689,8 @@ package body Sem_SPARK is Typ : Entity_Id; Kind : Formal_Kind; Subp : Entity_Id; - Global_Var : Boolean) + Global_Var : Boolean; + Expl : Node_Id) is Perm : Perm_Kind_Option; @@ -4965,14 +5742,6 @@ package body Sem_SPARK is -- Functions cannot have outputs in SPARK elsif Ekind (Subp) = E_Function then - if Kind = E_Out_Parameter then - Error_Msg_N ("function with OUT parameter is not " - & "allowed in SPARK", Id); - else - Error_Msg_N ("function with `IN OUT` parameter is not " - & "allowed in SPARK", Id); - end if; - return; -- Deep types define a borrow or a move @@ -4989,6 +5758,7 @@ package body Sem_SPARK is (Tree => (Kind => Entire_Object, Is_Node_Deep => Is_Deep (Etype (Id)), + Explanation => Expl, Permission => Perm, Children_Permission => Perm)); begin @@ -5008,12 +5778,47 @@ package body Sem_SPARK is while Present (Formal) loop Setup_Parameter_Or_Global (Id => Formal, - Typ => Underlying_Type (Etype (Formal)), + Typ => Retysp (Etype (Formal)), Kind => Ekind (Formal), Subp => Subp, - Global_Var => False); + Global_Var => False, + Expl => Formal); Next_Formal (Formal); end loop; end Setup_Parameters; + -------------------------------- + -- Setup_Protected_Components -- + -------------------------------- + + procedure Setup_Protected_Components (Subp : Entity_Id) is + Typ : constant Entity_Id := Scope (Subp); + Comp : Entity_Id; + Kind : Formal_Kind; + + begin + Comp := First_Component_Or_Discriminant (Typ); + + -- The protected object is an implicit input of protected functions, and + -- an implicit input-output of protected procedures and entries. + + if Ekind (Subp) = E_Function then + Kind := E_In_Parameter; + else + Kind := E_In_Out_Parameter; + end if; + + while Present (Comp) loop + Setup_Parameter_Or_Global + (Id => Comp, + Typ => Retysp (Etype (Comp)), + Kind => Kind, + Subp => Subp, + Global_Var => False, + Expl => Comp); + + Next_Component_Or_Discriminant (Comp); + end loop; + end Setup_Protected_Components; + end Sem_SPARK; diff --git a/gcc/ada/sem_spark.ads b/gcc/ada/sem_spark.ads index ee4126a..195e833 100644 --- a/gcc/ada/sem_spark.ads +++ b/gcc/ada/sem_spark.ads @@ -132,12 +132,38 @@ -- get read-write permission, which can be specified using the node's -- Children_Permission field. +-- The implementation is done as a generic, so that GNATprove can instantiate +-- it with suitable formal arguments that depend on the SPARK_Mode boundary +-- as well as the two-phase architecture of GNATprove (which runs the GNAT +-- front end twice, once for global generation and once for analysis). + with Types; use Types; +generic + with function Retysp (X : Entity_Id) return Entity_Id; + -- Return the representative type in SPARK for a type. + + with function Component_Is_Visible_In_SPARK (C : Entity_Id) return Boolean; + -- Return whether a component is visible in SPARK. No aliasing check is + -- performed for a component that is visible. + + with function Emit_Messages return Boolean; + -- Return True when error messages should be emitted. + package Sem_SPARK is procedure Check_Safe_Pointers (N : Node_Id); -- The entry point of this package. It analyzes a node and reports errors -- when there are violations of ownership rules. + function Is_Deep (Typ : Entity_Id) return Boolean; + -- A function that can tell whether a type is deep. Returns True if the + -- type passed as argument is deep. + + function Is_Traversal_Function (E : Entity_Id) return Boolean; + + function Is_Local_Context (Scop : Entity_Id) return Boolean; + -- Return if a given scope defines a local context where it is legal to + -- declare a variable of anonymous access type. + end Sem_SPARK; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 77eefdc..f18eb0f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6452,8 +6452,8 @@ package body Sem_Util is -- Dynamic_Accessibility_Level -- --------------------------------- - function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is - Loc : constant Source_Ptr := Sloc (Expr); + function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); function Make_Level_Literal (Level : Uint) return Node_Id; -- Construct an integer literal representing an accessibility level @@ -6473,7 +6473,12 @@ package body Sem_Util is -- Local variables - E : Entity_Id; + Expr : constant Node_Id := Original_Node (N); + -- Expr references the original node because at this stage N may be the + -- reference to a variable internally created by the frontend to remove + -- side effects of an expression. + + E : Entity_Id; -- Start of processing for Dynamic_Accessibility_Level @@ -6530,12 +6535,69 @@ package body Sem_Util is when N_Allocator => - -- Unimplemented: depends on context. As an actual parameter where - -- formal type is anonymous, use - -- Scope_Depth (Current_Scope) + 1. - -- For other cases, see 3.10.2(14/3) and following. ??? + -- This is not fully implemented since it depends on context (see + -- 3.10.2(14/3-14.2/3). More work is needed in the following cases + -- + -- 1) For an anonymous allocator defining the value of an access + -- parameter, the accessibility level is that of the innermost + -- master of the call; however currently we pass the level of + -- execution of the called subprogram, which is one greater + -- than the current scope level (see Expand_Call_Helper). + -- + -- For example, a statement is a master and a declaration is + -- not a master; so we should not pass in the same level for + -- the following cases: + -- + -- function F (X : access Integer) return T is ... ; + -- Decl : T := F (new Integer); -- level is off by one + -- begin + -- Decl := F (new Integer); -- we get this case right + -- + -- 2) For an anonymous allocator that defines the result of a + -- function with an access result, the accessibility level is + -- determined as though the allocator were in place of the call + -- of the function. In the special case of a call that is the + -- operand of a type conversion the level is that of the target + -- access type of the conversion. + -- + -- 3) For an anonymous allocator defining an access discriminant + -- the accessibility level is determined as follows: + -- * for an allocator used to define the discriminant of an + -- object, the level of the object + -- * for an allocator used to define the constraint in a + -- subtype_indication in any other context, the level of + -- the master that elaborates the subtype_indication. + + case Nkind (Parent (N)) is + when N_Object_Declaration => + + -- For an anonymous allocator whose type is that of a + -- stand-alone object of an anonymous access-to-object type, + -- the accessibility level is that of the declaration of the + -- stand-alone object. + + return + Make_Level_Literal + (Object_Access_Level + (Defining_Identifier (Parent (N)))); - null; + when N_Assignment_Statement => + return + Make_Level_Literal + (Object_Access_Level (Name (Parent (N)))); + + when others => + declare + S : constant String := + Node_Kind'Image (Nkind (Parent (N))); + begin + Error_Msg_Strlen := S'Length; + Error_Msg_String (1 .. Error_Msg_Strlen) := S; + Error_Msg_N + ("unsupported context for anonymous allocator (~)", + Parent (N)); + end; + end case; when N_Type_Conversion => if not Is_Local_Anonymous_Access (Etype (Expr)) then @@ -6840,8 +6902,9 @@ package body Sem_Util is elsif Dynamic_Scope = Empty then return Empty; - elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body, - E_Generic_Package) + elsif Ekind_In (Dynamic_Scope, E_Generic_Package, + E_Package, + E_Package_Body) then return Dynamic_Scope; @@ -6861,12 +6924,7 @@ package body Sem_Util is S := Scope (E); while Present (S) loop if Is_Package_Or_Generic_Package (S) - or else Ekind (S) = E_Package_Body - then - return S; - - elsif Is_Subprogram_Or_Generic_Subprogram (S) - or else Ekind (S) = E_Subprogram_Body + or else Is_Subprogram_Or_Generic_Subprogram (S) then return S; @@ -6895,7 +6953,7 @@ package body Sem_Util is elsif Ekind (Dyn_Scop) = E_Subprogram_Body then return Corresponding_Spec (Parent (Parent (Dyn_Scop))); - elsif Ekind_In (Dyn_Scop, E_Block, E_Return_Statement) then + elsif Ekind_In (Dyn_Scop, E_Block, E_Loop, E_Return_Statement) then return Enclosing_Subprogram (Dyn_Scop); elsif Ekind (Dyn_Scop) = E_Entry then @@ -8645,6 +8703,8 @@ package body Sem_Util is Global : Node_Id := Empty; Body_Id : Entity_Id; + -- Start of processing for First_Global + begin pragma Assert (Nam_In (Global_Mode, Name_In_Out, Name_Input, @@ -8655,7 +8715,22 @@ package body Sem_Util is -- case, it can only be located on the body entity. if Refined then - Body_Id := Subprogram_Body_Entity (Subp); + if Is_Subprogram_Or_Generic_Subprogram (Subp) then + Body_Id := Subprogram_Body_Entity (Subp); + + elsif Is_Entry (Subp) or else Is_Task_Type (Subp) then + Body_Id := Corresponding_Body (Parent (Subp)); + + -- ??? It should be possible to retrieve the Refined_Global on the + -- task body associated to the task object. This is not yet possible. + + elsif Is_Single_Task_Object (Subp) then + Body_Id := Empty; + + else + Body_Id := Empty; + end if; + if Present (Body_Id) then Global := Get_Pragma (Body_Id, Pragma_Refined_Global); end if; @@ -8939,6 +9014,12 @@ package body Sem_Util is begin Find_Discrete_Value : while Present (Variant) loop + + -- If a choice is a subtype with a static predicate, it must + -- be rewritten as an explicit list of non-predicated choices. + + Expand_Static_Predicates_In_Choices (Variant); + Discrete_Choice := First (Discrete_Choices (Variant)); while Present (Discrete_Choice) loop exit Find_Discrete_Value when @@ -10734,8 +10815,8 @@ package body Sem_Util is -- Simple option Synchronous -- -- enables disables - -- Asynch_Readers Effective_Reads - -- Asynch_Writers Effective_Writes + -- Async_Readers Effective_Reads + -- Async_Writers Effective_Writes -- -- Note that both forms of External have higher precedence than -- Synchronous (SPARK RM 7.1.4(9)). @@ -12305,6 +12386,25 @@ package body Sem_Util is end if; end In_Pre_Post_Condition; + ------------------------------ + -- In_Quantified_Expression -- + ------------------------------ + + function In_Quantified_Expression (N : Node_Id) return Boolean is + P : Node_Id; + begin + P := Parent (N); + loop + if No (P) then + return False; + elsif Nkind (P) = N_Quantified_Expression then + return True; + else + P := Parent (P); + end if; + end loop; + end In_Quantified_Expression; + ------------------------------------- -- In_Reverse_Storage_Order_Object -- ------------------------------------- @@ -19320,6 +19420,94 @@ package body Sem_Util is return Empty; end Nearest_Enclosing_Instance; + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (Typ : Entity_Id) return Boolean is + function Has_Some_Controlled_Component + (Input_Typ : Entity_Id) return Boolean; + -- Determine whether type Input_Typ has at least one controlled + -- component. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Input_Typ : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + -- When a type is already frozen and has at least one controlled + -- component, or is manually decorated, it is sufficient to inspect + -- flag Has_Controlled_Component. + + if Has_Controlled_Component (Input_Typ) then + return True; + + -- Otherwise inspect the internals of the type + + elsif not Is_Frozen (Input_Typ) then + if Is_Array_Type (Input_Typ) then + return Needs_Finalization (Component_Type (Input_Typ)); + + elsif Is_Record_Type (Input_Typ) then + Comp := First_Component (Input_Typ); + while Present (Comp) loop + if Needs_Finalization (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + end if; + end if; + + return False; + end Has_Some_Controlled_Component; + + -- Start of processing for Needs_Finalization + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types. + + if Restriction_Active (No_Finalization) then + return False; + + -- C++ types are not considered controlled. It is assumed that the non- + -- Ada side will handle their clean up. + + elsif Convention (Typ) = Convention_CPP then + return False; + + -- Class-wide types are treated as controlled because derivations from + -- the root type may introduce controlled components. + + elsif Is_Class_Wide_Type (Typ) then + return True; + + -- Concurrent types are controlled as long as their corresponding record + -- is controlled. + + elsif Is_Concurrent_Type (Typ) + and then Present (Corresponding_Record_Type (Typ)) + and then Needs_Finalization (Corresponding_Record_Type (Typ)) + then + return True; + + -- Otherwise the type is controlled when it is either derived from type + -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or + -- contains at least one controlled component. + + else + return + Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); + end if; + end Needs_Finalization; + ---------------------- -- Needs_One_Actual -- ---------------------- @@ -22181,9 +22369,15 @@ package body Sem_Util is -- Start of processing for Null_Status begin + -- Prevent cascaded errors or infinite loops when trying to determine + -- the null status of an erroneous construct. + + if Error_Posted (N) then + return Unknown; + -- An allocator always creates a non-null value - if Nkind (N) = N_Allocator then + elsif Nkind (N) = N_Allocator then return Is_Non_Null; -- Taking the 'Access of something yields a non-null value @@ -23327,6 +23521,13 @@ package body Sem_Util is if From_Typ = Typ then return; + + -- Nothing to do when the destination denotes an incomplete type + -- because the DIC is associated with the current instance of a + -- private type, thus it can never apply to an incomplete type. + + elsif Is_Incomplete_Type (Typ) then + return; end if; DIC_Proc := DIC_Procedure (From_Typ); @@ -24178,13 +24379,33 @@ package body Sem_Util is (Inner : Entity_Id; Outer : Entity_Id) return Boolean is - Curr : Entity_Id; + Curr : Entity_Id := Inner; begin - Curr := Inner; + -- Similar to the above, but check for scope identity first + while Present (Curr) and then Curr /= Standard_Standard loop if Curr = Outer then return True; + + elsif Ekind (Curr) = E_Task_Type + and then Outer = Task_Body_Procedure (Curr) + then + return True; + + elsif Is_Subprogram (Curr) + and then Outer = Protected_Body_Subprogram (Curr) + then + return True; + + elsif Is_Private_Type (Curr) + and then Present (Full_View (Curr)) + then + if Full_View (Curr) = Outer then + return True; + else + return Scope_Within (Full_View (Curr), Outer); + end if; end if; Curr := Scope (Curr); @@ -25656,6 +25877,8 @@ package body Sem_Util is end if; end; + elsif Is_Child_Unit (U) then + return Child_Prefix & Unique_Name (S) & "__" & This_Name; else return Unique_Name (S) & "__" & This_Name; end if; @@ -26407,12 +26630,12 @@ package body Sem_Util is -- A record type or type extension yields a synchronized object when its -- discriminants (if any) lack default values and all components are of - -- a type that yelds a synchronized object. + -- a type that yields a synchronized object. elsif Is_Record_Type (Typ) then -- Inspect all entities defined in the scope of the type, looking for - -- components of a type that does not yeld a synchronized object or + -- components of a type that does not yield a synchronized object or -- for discriminants with default values. Id := First_Entity (Typ); @@ -26442,6 +26665,7 @@ package body Sem_Util is -- synchronized object. if Etype (Typ) /= Typ + and then not Is_Private_Type (Etype (Typ)) and then not Yields_Synchronized_Object (Etype (Typ)) then return False; @@ -26457,11 +26681,19 @@ package body Sem_Util is elsif Is_Synchronized_Interface (Typ) then return True; - -- A task type yelds a synchronized object by default + -- A task type yields a synchronized object by default elsif Is_Task_Type (Typ) then return True; + -- A private type yields a synchronized object if its underlying type + -- does. + + elsif Is_Private_Type (Typ) + and then Present (Underlying_Type (Typ)) + then + return Yields_Synchronized_Object (Underlying_Type (Typ)); + -- Otherwise the type does not yield a synchronized object else diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 3f8d2e7..35ef111 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -622,11 +622,11 @@ package Sem_Util is -- private components of protected objects, but is generally useful when -- restriction No_Implicit_Heap_Allocation is active. - function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id; - -- Expr should be an expression of an access type. Builds an integer - -- literal except in cases involving anonymous access types, where - -- accessibility levels are tracked at run time (access parameters and - -- Ada 2012 stand-alone objects). + function Dynamic_Accessibility_Level (N : Node_Id) return Node_Id; + -- N should be an expression of an access type. Builds an integer literal + -- except in cases involving anonymous access types, where accessibility + -- levels are tracked at run time (access parameters and Ada 2012 stand- + -- alone objects). function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id; -- Same as Einfo.Extra_Accessibility except thtat object renames @@ -1410,6 +1410,9 @@ package Sem_Util is -- Returns True if node N appears within a pre/postcondition pragma. Note -- the pragma Check equivalents are NOT considered. + function In_Quantified_Expression (N : Node_Id) return Boolean; + -- Returns true if the expression N occurs within a quantified expression + function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean; -- Returns True if N denotes a component or subcomponent in a record or -- array that has Reverse_Storage_Order. @@ -2217,6 +2220,10 @@ package Sem_Util is -- Return the entity of the nearest enclosing instance which encapsulates -- entity E. If no such instance exits, return Empty. + function Needs_Finalization (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is controlled and this requires finalization + -- actions. + function Needs_One_Actual (E : Entity_Id) return Boolean; -- Returns True if a function has defaults for all but its first formal, -- which is a controlling formal. Used in Ada 2005 mode to solve the @@ -2851,6 +2858,10 @@ package Sem_Util is -- Return a unique name for entity E, which could be used to identify E -- across compilation units. + Child_Prefix : constant String := "ada___"; + -- Prefix for child packages when building a unique name for an entity. It + -- is included here to share between Unique_Name and gnatprove. + function Unit_Is_Visible (U : Entity_Id) return Boolean; -- Determine whether a compilation unit is visible in the current context, -- because there is a with_clause that makes the unit available. Used to diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 7e13aa5..ab85162 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -333,6 +333,11 @@ package body Sem_Warn is elsif Has_Warnings_Off (Entity (Name (N))) then return; + + -- Forget it if the parameter is not In + + elsif Has_Out_Or_In_Out_Parameter (Entity (Name (N))) then + return; end if; -- OK, see if we have one argument @@ -1408,9 +1413,13 @@ package body Sem_Warn is goto Continue; end if; - -- Check for unset reference + -- Check for unset reference. If type of object has + -- preelaborable initialization, warning is misleading. - if Warn_On_No_Value_Assigned and then Present (UR) then + if Warn_On_No_Value_Assigned + and then Present (UR) + and then not Known_To_Have_Preelab_Init (Etype (E1)) + then -- For other than access type, go back to original node to -- deal with case where original unset reference has been @@ -2698,7 +2707,7 @@ package body Sem_Warn is -- Flag any unused with clauses. For a subunit, check only the units -- in its context, not those of the parent, which may be needed by other - -- subunits. We will get the full warnings when we compile the parent, + -- subunits. We will get the full warnings when we compile the parent, -- but the following is helpful when compiling a subunit by itself. if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb index 66e9a82..377ea19 100644 --- a/gcc/ada/sfn_scan.adb +++ b/gcc/ada/sfn_scan.adb @@ -607,6 +607,7 @@ package body SFN_Scan is exception when others => + pragma Assert (P'Valid); Cursor := P - S'First + 1; raise; end Scan_SFN_Pragmas; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index b1e57bf..064147e 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -754,11 +754,16 @@ package Sinfo is -- GNATprove mode. As a special case, the front end does not insert a -- Do_Division_Check flag on float exponentiation expressions, for the case -- where the value is 0.0 and the exponent is negative, although this case - -- does lead to a division check failure. + -- does lead to a division check failure. As another special case, + -- the front end does not insert a Do_Range_Check on an allocator where + -- the designated type is scalar, and the designated type is more + -- constrained than the type of the initialized allocator value or the type + -- of the default value for an uninitialized allocator. - -- Note: the expander always takes care of the Do_Range check case, - -- so this flag will never be set in the expanded tree passed to the - -- back end code generator. + -- Note that the expander always takes care of the Do_Range_Check case, so + -- this flag will never be set in the expanded tree passed to the back end. + -- For the other two flags, the check can be generated either by the back + -- end or by the front end, depending on the setting of a target parameter. -- Note that this accounts for all nodes that trigger the corresponding -- checks, except for range checks on subtype_indications, which may be @@ -1182,9 +1187,10 @@ package Sinfo is -- conversion nodes (and set if the conversion requires a check). -- Do_Division_Check (Flag13-Sem) - -- This flag is set on a division operator (/ mod rem) to indicate - -- that a zero divide check is required. The actual check is dealt - -- with by the backend (all the front end does is to set the flag). + -- This flag is set on a division operator (/ mod rem) to indicate that + -- a zero divide check is required. The actual check is either dealt with + -- by the back end if Backend_Divide_Checks is set to true, or by the + -- front end itself if it is set to false. -- Do_Length_Check (Flag4-Sem) -- This flag is set in an N_Assignment_Statement, N_Op_And, N_Op_Or, @@ -1193,15 +1199,13 @@ package Sinfo is -- Do_Overflow_Check (Flag17-Sem) -- This flag is set on an operator where an overflow check is required on - -- the operation. The actual check is dealt with by the backend (all the - -- front end does is to set the flag). The other cases where this flag is - -- used is on a Type_Conversion node and for attribute reference nodes. + -- the operation. The actual check is either dealt with by the back end + -- if Backend_Overflow_Checks is set to true, or by the front end itself + -- if it is set to false. The other cases where this flag is used is on a + -- Type_Conversion node as well on if and case expression nodes. -- For a type conversion, it means that the conversion is from one base -- type to another, and the value may not fit in the target base type. - -- See also the description of Do_Range_Check for this case. The only - -- attribute references which use this flag are Pred and Succ, where it - -- means that the result should be checked for going outside the base - -- range. Note that this flag is not set for modular types. This flag is + -- See also the description of Do_Range_Check for this case. This flag is -- also set on if and case expression nodes if we are operating in either -- MINIMIZED or ELIMINATED overflow checking mode (to make sure that we -- properly process overflow checking for dependent expressions). @@ -1211,9 +1215,9 @@ package Sinfo is -- range check is required. The target type is clear from the context. -- The contexts in which this flag can appear are the following: - -- Right side of an assignment. In this case the target type is - -- taken from the left side of the assignment, which is referenced - -- by the Name of the N_Assignment_Statement node. + -- Right side of an assignment. In this case the target type is taken + -- from the left side of the assignment, which is referenced by the + -- Name of the N_Assignment_Statement node. -- Subscript expressions in an indexed component. In this case the -- target type is determined from the type of the array, which is @@ -1247,15 +1251,6 @@ package Sinfo is -- listed above (e.g. in a return statement), an additional type -- conversion node is introduced to represent the required check. - -- A special case arises for the arguments of the Pred/Succ attributes. - -- Here the range check needed is against First + 1 .. Last (Pred) or - -- First .. Last - 1 (Succ) of the corresponding base type. Essentially - -- these checks are what would be performed within the implicit body of - -- the functions that correspond to these attributes. In these cases, - -- the Do_Range check flag is set on the argument to the attribute - -- function, and the back end must special case the appropriate range - -- to check against. - -- Do_Storage_Check (Flag17-Sem) -- This flag is set in an N_Allocator node to indicate that a storage -- check is required for the allocation, or in an N_Subprogram_Body node diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 21cc0f4..2715310 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1511,6 +1511,11 @@ package Snames is Name_Runtime_Library_Dir : constant Name_Id := N + $; Name_Runtime_Source_Dir : constant Name_Id := N + $; + -- Additional names used by the Repinfo unit + + Name_Discriminant : constant Name_Id := N + $; + Name_Operands : constant Name_Id := N + $; + -- Other miscellaneous names used in front end Name_Unaligned_Valid : constant Name_Id := N + $; diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c index a265e01..8fc8415 100644 --- a/gcc/ada/socket.c +++ b/gcc/ada/socket.c @@ -803,4 +803,15 @@ const char * __gnat_gai_strerror(int errcode) { #endif +int __gnat_minus_500ms() { +#if defined (_WIN32) + // Windows Server 2019 and Windows 8.0 do not need 500 millisecond socket + // timeout correction. + return !(IsWindows8OrGreater() && !IsWindowsServer() + || IsWindowsVersionOrGreater(10, 0, 17763)); +#else + return 0; +#endif +} + #endif /* defined(HAVE_SOCKETS) */ diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index c17cf57..8a8139d 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -1483,9 +1483,9 @@ package body Sprint is end; when N_Decimal_Fixed_Point_Definition => - Write_Str_With_Col_Check_Sloc (" delta "); + Write_Str_With_Col_Check_Sloc ("delta "); Sprint_Node (Delta_Expression (Node)); - Write_Str_With_Col_Check ("digits "); + Write_Str_With_Col_Check (" digits "); Sprint_Node (Digits_Expression (Node)); Sprint_Opt_Node (Real_Range_Specification (Node)); @@ -4187,9 +4187,7 @@ package body Sprint is declare B : constant Node_Id := Etype (Typ); - X : Node_Id; P : constant Node_Id := Parent (Typ); - S : constant Saved_Output_Buffer := Save_Output_Buffer; -- Save current output buffer @@ -4197,6 +4195,8 @@ package body Sprint is -- Save sloc of related node, so it is not modified when -- printing with -gnatD. + X : Node_Id; + begin -- Write indentation at start of line @@ -4324,8 +4324,8 @@ package body Sprint is declare L : constant Node_Id := Type_Low_Bound (Typ); H : constant Node_Id := Type_High_Bound (Typ); - LE : Node_Id; - HE : Node_Id; + BL : Node_Id; + BH : Node_Id; begin -- B can either be a scalar type, in which case the @@ -4335,29 +4335,29 @@ package body Sprint is -- constraint. if Is_Scalar_Type (B) then - LE := Type_Low_Bound (B); - HE := Type_High_Bound (B); + BL := Type_Low_Bound (B); + BH := Type_High_Bound (B); else - LE := Empty; - HE := Empty; + BL := Empty; + BH := Empty; end if; - if No (LE) + if No (BL) or else (True and then Nkind (L) = N_Integer_Literal and then Nkind (H) = N_Integer_Literal - and then Nkind (LE) = N_Integer_Literal - and then Nkind (HE) = N_Integer_Literal - and then UI_Eq (Intval (L), Intval (LE)) - and then UI_Eq (Intval (H), Intval (HE))) + and then Nkind (BL) = N_Integer_Literal + and then Nkind (BH) = N_Integer_Literal + and then UI_Eq (Intval (L), Intval (BL)) + and then UI_Eq (Intval (H), Intval (BH))) then null; else Write_Str (" range "); - Sprint_Node (Type_Low_Bound (Typ)); + Sprint_Node (L); Write_Str (" .. "); - Sprint_Node (Type_High_Bound (Typ)); + Sprint_Node (H); end if; end; @@ -4368,7 +4368,7 @@ package body Sprint is Write_Str ("mod "); Write_Uint_With_Col_Check (Modulus (Typ), Auto); - -- Floating point types and subtypes + -- Floating-point types and subtypes when E_Floating_Point_Subtype | E_Floating_Point_Type @@ -4379,9 +4379,9 @@ package body Sprint is Write_Str ("new "); end if; - Write_Id (Etype (Typ)); + Write_Id (B); - if Digits_Value (Typ) /= Digits_Value (Etype (Typ)) then + if Digits_Value (Typ) /= Digits_Value (B) then Write_Str (" digits "); Write_Uint_With_Col_Check (Digits_Value (Typ), Decimal); @@ -4392,27 +4392,54 @@ package body Sprint is declare L : constant Node_Id := Type_Low_Bound (Typ); H : constant Node_Id := Type_High_Bound (Typ); - LE : constant Node_Id := Type_Low_Bound (B); - HE : constant Node_Id := Type_High_Bound (B); + BL : constant Node_Id := Type_Low_Bound (B); + BH : constant Node_Id := Type_High_Bound (B); begin - if Nkind (L) = N_Real_Literal + if True + and then Nkind (L) = N_Real_Literal and then Nkind (H) = N_Real_Literal - and then Nkind (LE) = N_Real_Literal - and then Nkind (HE) = N_Real_Literal - and then UR_Eq (Realval (L), Realval (LE)) - and then UR_Eq (Realval (H), Realval (HE)) + and then Nkind (BL) = N_Real_Literal + and then Nkind (BH) = N_Real_Literal + and then UR_Eq (Realval (L), Realval (BL)) + and then UR_Eq (Realval (H), Realval (BH)) then null; else Write_Str (" range "); - Sprint_Node (Type_Low_Bound (Typ)); + Sprint_Node (L); Write_Str (" .. "); - Sprint_Node (Type_High_Bound (Typ)); + Sprint_Node (H); end if; end; + -- Ordinary fixed-point types and subtypes + + when E_Ordinary_Fixed_Point_Subtype + | E_Ordinary_Fixed_Point_Type + => + Write_Header (Ekind (Typ) = E_Ordinary_Fixed_Point_Type); + + Write_Str ("delta "); + Write_Ureal_With_Col_Check_Sloc (Delta_Value (Typ)); + Write_Str (" range "); + Sprint_Node (Type_Low_Bound (Typ)); + Write_Str (" .. "); + Sprint_Node (Type_High_Bound (Typ)); + + -- Decimal fixed-point types and subtypes + + when E_Decimal_Fixed_Point_Subtype + | E_Decimal_Fixed_Point_Type + => + Write_Header (Ekind (Typ) = E_Decimal_Fixed_Point_Type); + + Write_Str ("delta "); + Write_Ureal_With_Col_Check_Sloc (Delta_Value (Typ)); + Write_Str (" digits "); + Write_Uint_With_Col_Check (Digits_Value (Typ), Decimal); + -- Record subtypes when E_Record_Subtype @@ -4493,16 +4520,16 @@ package body Sprint is when E_String_Literal_Subtype => declare - LB : constant Uint := + L : constant Uint := Expr_Value (String_Literal_Low_Bound (Typ)); Len : constant Uint := String_Literal_Length (Typ); begin Write_Header (False); Write_Str ("String ("); - Write_Int (UI_To_Int (LB)); + Write_Int (UI_To_Int (L)); Write_Str (" .. "); - Write_Int (UI_To_Int (LB + Len) - 1); + Write_Int (UI_To_Int (L + Len) - 1); Write_Str (");"); end; diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index b76b5d9..11a552f 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -70,7 +70,7 @@ package Sprint is -- Multiple concatenation expr && expr && expr ... && expr -- Multiply wi Treat_Fixed_As_Integer x #* y -- Multiply wi Rounded_Result x @* y - -- Operator with range check {operator} (e.g. {+}) + -- Operator with overflow check {operator} (e.g. {+}) -- Others choice for cleanup when all others -- Pop exception label %pop_xxx_exception_label -- Push exception label %push_xxx_exception_label (label) diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index dc62ec2..3902b66 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -353,6 +353,12 @@ package body Switch.B is Ptr := Ptr + 1; Usage_Requested := True; + -- Processing for H switch + + when 'H' => + Ptr := Ptr + 1; + Legacy_Elaboration_Order := True; + -- Processing for i switch when 'i' => diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 0fbc606..1e1f5ee 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -33,6 +33,7 @@ GNAT Run Time Library */ #ifdef __vxworks +#include "vxWorks.h" #include "ioLib.h" #if ! defined (VTHREADS) #include "dosFsLib.h" @@ -41,7 +42,6 @@ # include "nfsLib.h" #endif #include "selectLib.h" -#include "vxWorks.h" #include "version.h" #if defined (__RTP__) # include "vwModNum.h" @@ -54,8 +54,10 @@ #ifdef IN_RTS #define POSIX -#include "tconfig.h" -#include "tsystem.h" +#include "runtime.h" +#include <string.h> +#include <unistd.h> + #include <fcntl.h> #include <sys/stat.h> #else @@ -300,7 +302,7 @@ __gnat_set_mode (int handle ATTRIBUTE_UNUSED, int mode ATTRIBUTE_UNUSED) } char * -__gnat_ttyname (int filedes) +__gnat_ttyname (int filedes ATTRIBUTE_UNUSED) { #if defined (__vxworks) return ""; @@ -896,30 +898,34 @@ __gnat_get_task_options (void) #endif int -__gnat_is_file_not_found_error (int errno_val) { - switch (errno_val) { - case ENOENT: +__gnat_is_file_not_found_error (int errno_val) + { + /* WARNING: Do not rewrite this as a switch/case statement. + * Some of the "cases" are duplicated in some versions of + * Vxworks, notably VxWorks7r2 SR0610. */ + if (errno_val == ENOENT) + return 1; #ifdef __vxworks - /* In the case of VxWorks, we also have to take into account various - * filesystem-specific variants of this error. - */ + /* In the case of VxWorks, we also have to take into account various + * filesystem-specific variants of this error. + */ #if ! defined (VTHREADS) && (_WRS_VXWORKS_MAJOR < 7) - case S_dosFsLib_FILE_NOT_FOUND: + else if (errno_val == S_dosFsLib_FILE_NOT_FOUND) + return 1; #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) - case S_nfsLib_NFSERR_NOENT: + else if (errno_val == S_nfsLib_NFSERR_NOENT) + return 1; #endif #if defined (__RTP__) - /* An RTP can return an NFS file not found, and the NFS bits must - first be masked on to check the errno. */ - case M_nfsStat | ENOENT: + /* An RTP can return an NFS file not found, and the NFS bits must + first be masked on to check the errno. */ + else if (errno_val == (M_nfsStat | ENOENT)) + return 1; #endif #endif - return 1; - - default: - return 0; - } + else + return 0; } #if defined (__linux__) diff --git a/gcc/ada/targext.c b/gcc/ada/targext.c index 39d75d1..d761b2a 100644 --- a/gcc/ada/targext.c +++ b/gcc/ada/targext.c @@ -36,14 +36,21 @@ the file must be compiled with IN_GCC defined, even for the library. */ #ifdef IN_RTS + +#ifndef STANDALONE #include "tconfig.h" #include "tsystem.h" +#endif + #else #include "config.h" #include "system.h" #endif + +#ifndef STANDALONE #include "coretypes.h" #include "tm.h" +#endif #ifndef TARGET_OBJECT_SUFFIX #define TARGET_OBJECT_SUFFIX ".o" diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 23f9dfd..320ad28 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -108,7 +108,7 @@ __gnat_tty_supported (void) } int -__gnat_tty_waitpid (void *desc ATTRIBUTE_UNUSED) +__gnat_tty_waitpid (void *desc ATTRIBUTE_UNUSED, int blocking) { return 1; } @@ -152,6 +152,7 @@ __gnat_setup_winsize (void *desc ATTRIBUTE_UNUSED, #include <stdlib.h> #include <windows.h> +#include <winternl.h> #define MAXPATHLEN 1024 @@ -1014,20 +1015,28 @@ __gnat_terminate_pid (int pid) the Win32 API instead of the C one. */ int -__gnat_tty_waitpid (struct TTY_Process* p) +__gnat_tty_waitpid (struct TTY_Process* p, int blocking) { DWORD exitcode; - DWORD res; - HANDLE proc_hand = p->procinfo.hProcess; + HANDLE hprocess = p->procinfo.hProcess; - res = WaitForSingleObject (proc_hand, 0); - GetExitCodeProcess (proc_hand, &exitcode); + if (blocking) { + /* Wait is needed on Windows only in blocking mode. */ + WaitForSingleObject (hprocess, 0); + } - CloseHandle (p->procinfo.hThread); - CloseHandle (p->procinfo.hProcess); + GetExitCodeProcess (hprocess, &exitcode); - /* No need to close the handles: they were closed on the ada side */ + if (exitcode == STILL_ACTIVE) { + /* If process is still active return -1. */ + exitcode = -1; + } else { + /* Process is dead, so handle to process and main thread can be closed. */ + CloseHandle (p->procinfo.hThread); + CloseHandle (hprocess); + } + /* No need to close the handles: they were closed on the ada side */ return (int) exitcode; } @@ -1556,11 +1565,21 @@ __gnat_terminate_pid (int pid) * exit status of the child process */ int -__gnat_tty_waitpid (pty_desc *desc) +__gnat_tty_waitpid (pty_desc *desc, int blocking) { - int status = 0; - waitpid (desc->child_pid, &status, 0); - return WEXITSTATUS (status); + int status = -1; + int options = 0; + + if (blocking) { + options = 0; + } else { + options = WNOHANG; + } + waitpid (desc->child_pid, &status, options); + if WIFEXITED (status) { + status = WEXITSTATUS (status); + } + return status; } /* __gnat_tty_supported - Are tty supported ? diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index a43dc4d..9e74282 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -50,14 +50,10 @@ extern "C" { #endif -#ifdef __alpha_vxworks -#include "vxWorks.h" -#endif - #ifdef IN_RTS #define POSIX -#include "tconfig.h" -#include "tsystem.h" +#include "runtime.h" +#include <stddef.h> #else #include "config.h" #include "system.h" diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 1eace05..fb261e5 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -483,6 +483,8 @@ begin Write_Line (" A turn off all optional info/warnings"); Write_Line (" .a*+ turn on warnings for failing assertion"); Write_Line (" .A turn off warnings for failing assertion"); + Write_Line (" _a*+ turn on warnings for anonymous allocators"); + Write_Line (" _A turn off warnings for anonymous allocators"); Write_Line (" b+ turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb index d08299d..ae155c3 100644 --- a/gcc/ada/validsw.adb +++ b/gcc/ada/validsw.adb @@ -36,11 +36,12 @@ package body Validsw is begin Validity_Check_Components := False; Validity_Check_Copies := False; - Validity_Check_Default := True; + Validity_Check_Default := False; Validity_Check_Floating_Point := False; Validity_Check_In_Out_Params := False; Validity_Check_In_Params := False; Validity_Check_Operands := False; + Validity_Check_Parameters := False; Validity_Check_Returns := False; Validity_Check_Subscripts := False; Validity_Check_Tests := False; @@ -73,14 +74,14 @@ package body Validsw is Options (K) := ' '; end loop; - Add ('n', not Validity_Check_Default); - - Add ('c', Validity_Check_Copies); Add ('e', Validity_Check_Components); + Add ('c', Validity_Check_Copies); + Add ('d', Validity_Check_Default); Add ('f', Validity_Check_Floating_Point); Add ('i', Validity_Check_In_Params); Add ('m', Validity_Check_In_Out_Params); Add ('o', Validity_Check_Operands); + Add ('p', Validity_Check_Parameters); Add ('r', Validity_Check_Returns); Add ('s', Validity_Check_Subscripts); Add ('t', Validity_Check_Tests); diff --git a/gcc/ada/validsw.ads b/gcc/ada/validsw.ads index 2dadc5c..5197bdf 100644 --- a/gcc/ada/validsw.ads +++ b/gcc/ada/validsw.ads @@ -40,33 +40,33 @@ package Validsw is -- or in the argument of a Validity_Checks pragma to activate the option. -- The corresponding upper case letter deactivates the option. + Validity_Check_Components : Boolean := False; + -- Controls validity checking for assignment to elementary components of + -- records. If this switch is set to True using -gnatVe, or an 'e' in the + -- argument of Validity_Checks pragma, then the right-hand side of an + -- assignment to such a component is checked for validity. + Validity_Check_Copies : Boolean := False; -- Controls the validity checking of copies. If this switch is set to - -- true using -gnatVc, or a 'c' in the argument of a Validity_Checks - -- pragma, then the right side of assignments and also initializing + -- True using -gnatVc, or a 'c' in the argument of a Validity_Checks + -- pragma, then the right-hand side of assignments and also initializing -- expressions in object declarations are checked for validity. - Validity_Check_Components : Boolean := False; - -- Controls validity checking for assignment to elementary components of - -- records. If this switch is set true using -gnatVe, or an 'e' in the - -- argument of Validity_Checks pragma, then the right hand of an assignment - -- to such a component is checked for validity. - Validity_Check_Default : Boolean := True; -- Controls default (reference manual) validity checking. If this switch is -- set to True using -gnatVd or a 'd' in the argument of a Validity_Checks - -- pragma (or the initial default value is used, set True), then left side - -- subscripts and case statement arguments are checked for validity. This - -- switch is also set by default if no -gnatV switch is used and no + -- pragma (or the initial default value is used, set True), then left-hand + -- side subscripts and case statement arguments are checked for validity. + -- This switch is also set by default if no -gnatV switch is used and no -- Validity_Checks pragma is processed. Validity_Check_Floating_Point : Boolean := False; - -- Normally validity checking applies only to discrete values (integer - -- and enumeration types). If this switch is set to True using -gnatVf - -- or an 'f' in the argument of a Validity_Checks pragma, then floating- - -- point values are also checked. The context in which such checks - -- occur depends on other flags, e.g. if Validity_Check_Copies is also - -- set then floating-point values on the right side of an assignment + -- Normally validity checking applies only to discrete values (integer and + -- enumeration types). If this switch is set to True using -gnatVf or an + -- 'f' in the argument of a Validity_Checks pragma, then floating-point + -- values are also checked. If the context in which such checks occur + -- depends on other flags, e.g. if Validity_Check_Copies is also set, + -- then floating-point values on the right-hand side of an assignment -- will be validity checked. Validity_Check_In_Out_Params : Boolean := False; @@ -103,13 +103,13 @@ package Validsw is -- pragma, then the expression in a RETURN statement is validity checked. Validity_Check_Subscripts : Boolean := False; - -- Controls validity checking of subscripts. If this switch is set to - -- True using -gnatVs, or an 's' in the argument of a Validity_Checks - -- pragma, then all subscripts are checked for validity. Note that left - -- side subscript checking is controlled also by Validity_Check_Default. - -- If Validity_Check_Subscripts is True, then all subscripts are checked, - -- otherwise if Validity_Check_Default is True, then left side subscripts - -- are checked, otherwise no subscripts are checked. + -- Controls validity checking of subscripts. If this switch is set to True + -- using -gnatVs, or an 's' in the argument of a Validity_Checks pragma, + -- then all subscripts are checked for validity. Note that left-hand side + -- subscript checking is also controlled by Validity_Check_Default. If + -- Validity_Check_Subscripts is True, then all subscripts are checked, + -- otherwise if Validity_Check_Default is True, then left-hand side + -- subscripts are checked; otherwise no subscripts are checked. Validity_Check_Tests : Boolean := False; -- Controls validity checking of tests that occur in conditions (i.e. the diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 472f1df..219d440 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -56,6 +56,7 @@ package body Warnsw is Warn_On_Ada_2005_Compatibility := Setting; Warn_On_Ada_2012_Compatibility := Setting; Warn_On_All_Unread_Out_Parameters := Setting; + Warn_On_Anonymous_Allocators := Setting; Warn_On_Assertion_Failure := Setting; Warn_On_Assumed_Low_Bound := Setting; Warn_On_Atomic_Synchronization := Setting; @@ -129,6 +130,8 @@ package body Warnsw is W.Warn_On_Ada_2012_Compatibility; Warn_On_All_Unread_Out_Parameters := W.Warn_On_All_Unread_Out_Parameters; + Warn_On_Anonymous_Allocators := + W.Warn_On_Anonymous_Allocators; Warn_On_Assertion_Failure := W.Warn_On_Assertion_Failure; Warn_On_Assumed_Low_Bound := @@ -235,6 +238,8 @@ package body Warnsw is Warn_On_Ada_2012_Compatibility; W.Warn_On_All_Unread_Out_Parameters := Warn_On_All_Unread_Out_Parameters; + W.Warn_On_Anonymous_Allocators := + Warn_On_Anonymous_Allocators; W.Warn_On_Assertion_Failure := Warn_On_Assertion_Failure; W.Warn_On_Assumed_Low_Bound := @@ -478,6 +483,12 @@ package body Warnsw is function Set_Underscore_Warning_Switch (C : Character) return Boolean is begin case C is + when 'a' => + Warn_On_Anonymous_Allocators := True; + + when 'A' => + Warn_On_Anonymous_Allocators := False; + when others => if Ignore_Unrecognized_VWY_Switches then Write_Line ("unrecognized switch -gnatw_" & C & " ignored"); @@ -705,6 +716,7 @@ package body Warnsw is Ineffective_Inline_Warnings := True; -- -gnatwp Warn_On_Ada_2005_Compatibility := True; -- -gnatwy Warn_On_Ada_2012_Compatibility := True; -- -gnatwy + Warn_On_Anonymous_Allocators := True; -- -gnatw_a Warn_On_Assertion_Failure := True; -- -gnatw.a Warn_On_Assumed_Low_Bound := True; -- -gnatww Warn_On_Bad_Fixed_Value := True; -- -gnatwb diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 23970a9..422f8df 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -38,6 +38,12 @@ package Warnsw is -- here as time goes by. And in fact a really nice idea would be to put -- them all in a Warn_Record so that they would be easy to save/restore. + Warn_On_Anonymous_Allocators : Boolean := False; + -- Warn when allocators for anonymous access types are present, which, + -- although not illegal in Ada, may be confusing to users due to how + -- accessibility checks get generated. Off by default, modified by use + -- of -gnatw_a/_A and set as part of -gnatwa. + Warn_On_Late_Primitives : Boolean := False; -- Warn when tagged type public primitives are defined after its private -- extensions. @@ -90,6 +96,7 @@ package Warnsw is Warn_On_Ada_2005_Compatibility : Boolean; Warn_On_Ada_2012_Compatibility : Boolean; Warn_On_All_Unread_Out_Parameters : Boolean; + Warn_On_Anonymous_Allocators : Boolean; Warn_On_Assertion_Failure : Boolean; Warn_On_Assumed_Low_Bound : Boolean; Warn_On_Atomic_Synchronization : Boolean; diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb index 0d5f635..7c72e4e 100644 --- a/gcc/ada/xoscons.adb +++ b/gcc/ada/xoscons.adb @@ -229,8 +229,7 @@ procedure XOSCons is case Lang is when Lang_Ada => Put (" subtype " & Info.Constant_Name.all - & " is Interfaces.C." - & Info.Text_Value.all & ";"); + & " is " & Info.Text_Value.all & ";"); when Lang_C => Put ("#define " & Info.Constant_Name.all & " " & Info.Text_Value.all); diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index 8b9c70a..4d400f3 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -1876,7 +1876,7 @@ package body Xref_Lib is end if; exception - when No_Xref_Information => null; + when No_Xref_Information => null; end; end loop; end Search_Xref; |