diff options
Diffstat (limited to 'gcc/ada')
301 files changed, 36087 insertions, 19020 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 36890b822f0..03ea684e8c8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,2612 @@ +2010-06-29 Nathan Froyd <froydnj@codesourcery.com> + + * gcc-interface/gigi.h (gnat_build_constructor): Take a VEC instead + of a TREE_LIST. Update comment. + * gcc-interface/trans.c (gigi): Build a VEC instead of a TREE_LIST. + Adjust call to gnat_build_constructor. + (Attribute_to_gnu): Likewise. + (gnat_to_gnu): Likewise. + (pos_to_constructor): Likewise. + (extract_values): Likewise. + * gcc-interface/utils.c (build_template): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (convert_to_fat_pointer): Likewise. + (convert): Likewise. + (unchecked_convert): Likewise. + * gcc-interface/decl.c (gnat_to_gnu_entity): Likewise. + * gcc-interface/utils2.c (build_allocator): Likewise. + (fill_vms_descriptor): Likewise. + (gnat_build_constructor): Take a VEC instead of a TREE_LIST. + (compare_elmt_bitpos): Adjust for parameters being constructor_elts + instead of TREE_LISTs. + +2010-06-28 Steven Bosscher <steven@gcc.gnu.org> + + * gcc-interface/misc.c: Do not include except.h. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-27 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c: Include tree-flow.h. + (gnu_switch_label_stack): Delete. + (Case_Statement_to_gnu): Do not emit the goto at the end of a case if + its associated block cannot fall through. Do not emit the final label + if no cases branch to it. + * gcc-interface/Make-lang.in (ada/trans.o): Add $(TREE_FLOW_H). + +2010-06-23 Thomas Quinot <quinot@adacore.com> + + * exp_attr.adb (Expand_Access_To_Protected_Op): When rewriting a + reference to a protected subprogram outside of the protected's scope, + ensure the corresponding external subprogram is frozen before the + reference. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_prag.adb: Fix typo in error message. + * sem.adb: Refine previous change. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * impunit.adb, a-suewen.adb, a-suewen.ads, a-suenco.adb, a-suenco.ads, + a-suezen.adb, a-suezen.ads, a-stuten.adb, a-stuten.ads, Makefile.rtl: + Implement Ada 2012 string encoding packages. + +2010-06-23 Arnaud Charlet <charlet@adacore.com> + + * a-stwiun-shared.adb, a-stwiun-shared.ads, a-stzunb-shared.adb, + a-stzunb-shared.ads, a-swunau-shared.adb, a-swuwti-shared.adb, + a-szunau-shared.adb, a-szuzti-shared.adb, a-strunb-shared.adb, + a-strunb-shared.ads, a-stunau-shared.adb, a-suteio-shared.adb: New + files. + * gcc-interface/Makefile.in: Enable use of above files. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Check_Constant_Address_Clauses): Do not check legality + of address clauses if if Ignore_Rep_Clauses is active. + * freeze.adb (Check_Address_Clause): If Ignore_Rep_Clauses is active, + remove address clause from tree so that it does not reach the backend. + +2010-06-23 Arnaud Charlet <charlet@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Valid]): Do not + expand 'Valid from user code in CodePeer mode, will be handled by the + back-end directly. + +2010-06-23 Bob Duff <duff@adacore.com> + + * g-comlin.ads: Minor comment improvements. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Uses_SS): The expression that initializes a controlled + component of a record type may be a user-defined operator that is + rewritten as a function call. + +2010-06-23 Bob Duff <duff@adacore.com> + + * g-comlin.ads, sem_ch13.adb: Minor comment fix. + +2010-06-23 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch11.adb (Expand_Local_Exception_Handlers): Propagate the end + label to the new sequence of statements. Set the sloc of the raise + statement onto the new goto statements. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * a-stuten.ads, a-stuten.adb: New files. + * impunit.adb: Add engtry for Ada.Strings.UTF_Encoding (a-stuten.ads) + * Makefile.rtl: Add entry for a-stuten (Ada.Strings.UTF_Encoding) + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Add documentation of -gnat12 switch + Add documentation of -gnatX switch. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * inline.ads: Include the current Ada_Version in the info for pending + instance bodies, so that declaration and body are compiled with the + same Ada_Version. + * inline.adb: Move with_clause for Opt to spec. + * sem_ch12.adb (Analyze_Package_Instantiation, + Analyze_Subprogram_Instantiation): Save current Ada_Version in + Pending_Instantiation information. + (Instantiate_Package_Body, Instantiate_Subprogram_Body, + Inline_Package_Body): Use the Ada_Version present in the body + information. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * usage.adb: Add documentation for -gnat12 switch. + * errout.ads: Add VMS alias entry for -gnat12 switch + * gnat_rm.texi: Add documentation for pragma Ada_12 and Ada_2012 + Add documentation for pragma Extensions_Allowed. + * opt.ads: Add entry for Ada 2012 mode. + * sem_ch4.adb, par-ch3.adb, par-ch4.adb: Use new Ada 2012 mode for 2012 + features. + * sem_prag.adb, par-prag.adb: Add processing for pragma Ada_12 and + Ada_2012. + * sem_ch13.adb: Add handling for Ada 2012 mode. + * snames.ads-tmpl: Add entries for pragma Ada_2012 and Ada_12. + * switch-c.adb: Add handling for -gnat12 switch. + Implement -gnat2005 and -gnat2012. + * usage.adb: Add documentation for -gnat12 switch. + * vms_data.ads: Add /12 switch for Ada 2012 mode. + +2010-06-23 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb (Expand_N_Allocator): Fix potential crash when using + No_Task_Hierarchy restriction. Add comment. + * exp_ch9.adb, exp_ch3.adb: Update comments. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * sem_ch5.adb (Process_Bounds): Remove some junk initializations. + * sem_res.adb: Add comments. + * sem_util.adb: Minor reformatting. Add comments. + Change increment on Actuals_In_Call table. + * opt.ads: Minor: add 'constant'. + +2010-06-23 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Make_DT): Initialize the Size_Func component of the + TSD to Null_Address if No_Dispatching_Calls is active. + +2010-06-23 Vincent Celier <celier@adacore.com> + + * a-comlin.ads: Indicate that use of this package is not supported + during the elaboration of an auto-initialized Stand-Alone Library. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * exp_util.adb (Is_Possibly_Misaligned_Object): Do not rely on an + alignment clause on a record type to determine if a component may be + misaligned. The decision must be taken in the back-end where target + alignment information is known. + +2010-06-23 Arnaud Charlet <charlet@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Enable some restrictions + systematically in CodePeer mode to simplify generated code. + * restrict.adb (Check_Restriction): Do nothing in CodePeer mode. + * exp_ch4.adb (Expand_N_Allocator): Generate proper code when + No_Task_Hierarchy is set instead of crasshing. + +2010-06-23 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb: Minor code cleanup: test for proper entity instead of + testing just Chars attribute when checking whether a given scope is + System. + * exp_ch4.adb, einfo.adb: Minor reformatting. + +2010-06-23 Vincent Celier <celier@adacore.com> + + PR ada/44633 + * switch-m.adb (Normalize_Compiler_Switches): Take into account + switches -gnatB, -gnatD=nn, -gnatG (incuding -gnatG=nn), -gnatI, + -gnatl=file, -gnatS, -gnatjnn, -gnateI=nn and -gnatWx. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Membership_Op): If left operand is a mixed mode + operation with a universal real operand, and the right operand is a + range with universal bounds, find unique fixed point that may be + candidate, and warn appropriately. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Intrinsic_Operator): Add guards to handle + properly the rare cases where VMS operators are visible through + Extend_System, but the default System is being used and Address is a + private type. + * sem_util.adb: Widen predicate Is_VMS_Operator. + +2010-06-23 Vincent Celier <celier@adacore.com> + + * switch-m.adb (Normalize_Compiler_Switches): Take into account -gnatC + and -gnateS. + +2010-06-23 Olivier Hainque <hainque@adacore.com> + + * einfo.adb (Has_Foreign_Convention): Consider Intrinsic with + Interface_Name as foreign. These are GCC builtin imports for + which Ada specific processing doesn't apply. + +2010-06-23 Thomas Quinot <quinot@adacore.com> + + * sem_ch12.adb: Minor reformatting. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Is_VMS_Operator): Use scope of system extension to + determine whether an intrinsic subprogram is VMS specific. + +2010-06-23 Hristian Kirtchev <kirtchev@adacore.com> + + * treepr.adb (Print_Entity_Info): Output the contents of Field28 if it + is present in the entity. + +2010-06-23 Arnaud Charlet <charlet@adacore.com> + + * xr_tabls.adb, xref_lib.adb: Update to latest lib-xref.ads + Fix handling of parameters. + Add protection against unexpected cases. + * sem_ch6.adb (Create_Extra_Formals): Use suffix "L" instead of "A" for + access level, since "A" suffix is already used elsewhere. Similarly, + use suffix "O" instead of "C" for 'Constrained since "C" suffix is used + for xxx'Class. + +2010-06-23 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb, sem_util.ads: Minor reformatting. + +2010-06-23 Vincent Celier <celier@adacore.com> + + * prj.ads (Gprclean_Flags.Missing_Source_Files): Set to Error to keep + the previous behavior of gprclean when there are missing files. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Load_Body_Of_Generic): In CodePeer mode, a missing + generic body is not a fatal error. + (Mark_Context): Handle properly names of child units. + * sem.adb (Walk_Library_Items.Do_Action): Remove assertion on + instantiations. + +2010-06-23 Vincent Celier <celier@adacore.com> + + * ali.adb (Scan_ALI): When ignoring R lines, do not skip the next + non-empty line. + +2010-06-23 Bob Duff <duff@adacore.com> + + * g-pehage.ads, g-pehage.adb: Switch default optimization mode to + Memory_Space, because CPU_Time doesn't seem to provide any significant + speed advantage in practice. Cleanup: Get rid of constant + Default_Optimization; doesn't seem to add anything. Use case + statements instead of if statements; seems cleaner. + +2010-06-23 Olivier Hainque <hainque@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <case E_Procedure>: Use + Wshadow instead of Wextra to guard warning on absence of internal + builtin decl for an import. Fix use of quote in warning text. + (intrin_arglists_compatible_p): Remove processing of integer trailing + args on the Ada side. Fix use of literal > in warning text. + (intrin_return_compatible_p): Never warn on "function imported as + procedure". Defer the void/void case to the common type compatibility + check. + (gnat_to_gnu_param): Use void_ptr GCC type for System.Address argument + of GCC builtin imports. + +2010-06-23 Olivier Hainque <hainque@adacore.com> + + * gcc-interface/decl.c (intrin_types_incompatible_p): New function, + helper for ... + (intrin_arglists_compatible_p, intrin_return_compatible_p): New + functions, helpers for ... + (intrin_profiles_compatible_p): New function, replacement for ... + (compatible_signatures_p): Removed. + (gnat_to_gnu_entity) <case E_Procedure>: If -Wextra, warn on + attempt to bind an unregistered builtin function. When we have + one, use it and warn on profile incompatibilities. + +2010-06-23 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Mark_Coextensions): If the expression in the allocator + for a coextension in an object declaration is a concatenation, treat + coextension as dynamic. + +2010-06-23 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Add_Internal_Interface_Entities): Ensure that the + internal entities are added to the scope of the tagged type. + (Derive_Subprograms): Do not stop derivation when we find the first + internal entity that has attribute Interface_Alias. After the change + done to Override_Dispatching_Operations it is no longer true that + these primirives are always located at the end of the list of + primitives. + * einfo.ads (Primitive_Operations): Add documentation. + * exp_disp.adb (Write_DT): Improve output adding to the name of the + primitive a prefix indicating its corresponding tagged type. + * sem_disp.adb (Override_Dispatching_Operations): If the overridden + entity covers the primitive of an interface that is not an ancestor of + this tagged type then the new primitive is added at the end of the list + of primitives. Required to fulfill the C++ ABI. + +2010-06-23 Javier Miranda <miranda@adacore.com> + + * atree.ads (Set_Reporting_Proc): New subprogram. + * atree.adb: Remove dependency on packages Opt and SCIL_LL. + (Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls + to routines of package Scil_ll by indirect call to the registered + subprogram. + (Set_Reporting_Proc): New subprogram. Used to register a subprogram + that is invoked when a node is allocated, replaced or rewritten. + * scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying + the SCIL node. Used as argument for Set_Reporting_Proc. + (Initialize): Register Copy_SCIL_Node as the reporting routine that + is invoked by atree. + +2010-06-23 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.ads: Minor reformatting. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode, + always analyze the generic body and instance, because it may be needed + downstream. + (Mark_Context): Prepend the with clauses for needed generic units, so + they appear in a better order for CodePeer. + * sem_util.adb, sem_util.ads: Prototype code for AI05-0144. + +2010-06-23 Emmanuel Briot <briot@adacore.com> + + * prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * g-pehage.adb, exp_ch13.adb: Minor reformatting. + +2010-06-23 Thomas Quinot <quinot@adacore.com> + + * a-tags.ads: Fix description of TSD structure. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Mark_Context): When indicating that the body of a + generic unit is needed prior to the unit containing an instantiation, + search recursively the context of the generic to add other generic + bodies that may be instantiated indirectly through the current instance. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor reformatting. + +2010-06-23 Bob Duff <duff@adacore.com> + + * g-pehage.adb (Trim_Trailing_Nuls): Fix the code to match the comment. + +2010-06-23 Vincent Celier <celier@adacore.com> + + * make.adb (Compile_Sources): Complete previous change. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Add_Extra_Formal): Use suffix "C" in the name of the + Constrained extra formal. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch13.adb (Expand_Freeze_Actions): If validity checks and + Initialize_Scalars are enabled, compile the generated equality function + for a composite type with full checks enabled, so that validity checks + are performed on individual components. + +2010-06-23 Emmanuel Briot <briot@adacore.com> + + * prj.adb, prj.ads, prj-nmsc.adb (Processing_Flags): New flag + Missing_Source_Files. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * exp_ch3.adb, exp_util.adb: Minor reformatting. + +2010-06-23 Jose Ruiz <ruiz@adacore.com> + + * a-reatim.adb, a-retide.adb: Move the initialization of the tasking + run time from Ada.Real_Time.Delays to Ada.Real_Time. This way, calls to + Clock (without delays) use a run time which is properly initialized. + +2010-06-23 Vincent Celier <celier@adacore.com> + + * make.adb: Do not set Check_Readonly_Files when setting Must_Compile, + when -f -u and a main is specified on the command line. However, + attempt to compile even when the ALI file is read-only when + Must_Compile is True. + +2010-06-23 Thomas Quinot <quinot@adacore.com> + + * checks.adb, g-pehage.adb, cstand.adb: Minor code factorization. + +2010-06-23 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal + entities for parent types that are interfaces. Needed in generics to + handle formals that implement interfaces. + (Derive_Subprograms): Add assertion for derivation of tagged types that + do not cover interfaces. For generics, complete code that handles + derivation of type that covers interfaces because the previous + condition was weak (it required only name consistency; arguments were + not checked). Add new code to locate primitives covering interfaces + defined in generic units or instantiatons. + * sem_util.adb (Has_Interfaces): Add missing support for derived types. + * sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups. + * exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of + interfaces that are parents of the type because they share the primary + dispatch table. + (Register_Primitive): Do not register primitives of interfaces that + are parents of the type. + * sem_ch13.adb (Analyze_Freeze_Entity): Add documentation. + * exp_cg.adb (Write_Type_Info): When displaying overriding of interface + primitives skip primitives of interfaces that are parents of the type. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Eval_Attribute): If the prefix is an array, the + attribute cannot be constant-folded if an index type is a formal type, + or is derived from one. + * checks.adb (Determine_Range): ditto. + +2010-06-23 Arnaud Charlet <charlet@adacore.com> + + * gnat_ugn.texi, gnatxref.adb: Add support for --ext switch. + +2010-06-23 Bob Duff <duff@adacore.com> + + * g-pehage.ads, g-pehage.adb (Put): Fix off-by-one bug. + (Insert): Disallow nul characters. + (misc output routines): Assert no nul characters. + +2010-06-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb: Use predefined unsigned type in all cases. + +2010-06-23 Bob Duff <duff@adacore.com> + + * s-rannum.adb (Reset): Avoid overflow in calculation of Initiator. + * g-pehage.ads: Minor comment fixes. + * g-pehage.adb: Minor: Add some additional debugging printouts under + Verbose flag. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * binde.adb (Better_Choice): Always prefer Pure/Preelab. + (Worse_Choice): Always prefer Pure/Preelab. + +2010-06-23 Vincent Celier <celier@adacore.com> + + * a-reatim.adb: Call System.OS_Primitives.Initialize during elaboration + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Properly handle + checking returns in generic case. + (Check_Missing_Return): New procedure. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * bindgen.adb, switch-b.adb: Minor reformatting. + +2010-06-23 Javier Miranda <miranda@adacore.com> + + * frontend.adb (Frontend): Add call to initialize the new package + SCIL_LL. + * exp_ch7.adb (Wrap_Transient_Expression): Remove call to + Adjust_SCIL_Node. + (Wrap_Transient_Statement): Remove call to Adjust_SCIL_Node. + * sem_ch5.adb (Analyze_Iteration_Scheme.Process_Bounds): Remove call to + Adjust_SCIL_Node. + * exp_util.adb (Insert_Actions): Remove code for + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + (Remove_Side_Effects): Remove calls to Adjust_SCIL_Node. + * sinfo.adb (SCIL_Entity, SCIL_Tag_Value): Remove checks on + N_SCIL_Tag_Init and N_SCIL_Dispatch_Table_Object_Init in the assertion. + (SCIL_Related_Node, Set_SCIL_Related_Node): Removed. + * sinfo.ads (SCIL_Related_Node): Field removed. + (N_SCIL_Dispatch_Table_Object_Init): Node removed. + (N_SCIL_Tag_Init): Node removed. + * sem_scil.ads, sem_scil.adb (Adjust_SCIL_Node): Removed. + (Check_SCIL_Node): New implementation. + (Find_SCIL_Node): Removed. + * sem.adb (Analyze): Remove management of + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + * sem_util.adb (Insert_Explicit_Dereference): Remove call to + Adjust_SCIL_Node. + * exp_ch4.adb (Expand_N_In): Code cleanup: remove call to + Set_SCIL_Related_Node and avoid adding the SCIL node before the + referenced node using Insert_Action because this is not longer required. + (Expand_Short_Circuit_Operator): Remove call to SCIL node. + * exp_ch6.adb (Expand_Call): Remove call to Adjust_SCIL_Node. + * sem_ch4.adb (Analyze_Type_Conversion): Remove call to Adjust_SCIL_Node + * exp_disp.adb (Expand_Dispatching_Call): Minor code reorganization + because we no longer require to generate the SCIL node before the call. + (Make_DT): Remove generation of SCI_Dispatch_Table_Object_Init node. + Remove calls to Set_SCIL_Related_Node and avoid adding the SCIL + nodes before the referenced node using Insert_Action because this + is not longer required. + * atree.adb (Allocate_Initialize_Node, Replace, Rewrite): Add call to + update the SCIL_Node field. + * sprint.adb (Sprint_Node_Actual): Remove code for + N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes. + * treepr.adb (Print_Node): Print the SCIL node field (if available). + * exp_ch3.adb (Build_Init_Procedure): Remove generation of + SCIL_Tag_Init nodes. + * scil_ll.ads, scil_ll.adb: New files. + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb: Minor reformatting. + +2010-06-23 Doug Rupp <rupp@adacore.com> + + * bindusg.adb (Display): Write -Hnn line. + * bindgen.adb (Gen_Adainit_Ada): Write Heap_Size to binder file as + necessary. + * init.c (__gl_heap_size): Rename from __gl_no_malloc_64 and change + valid values to 32 and 64. + (GNAT$NO_MALLOC_64): Recognize TRUE, 1, FALSE, and 0 in addition to + ENABLE, DISABLE as valid settings. + * switch-b.adb (Scan_Binder_Switches): Process -Hnn switch. + * opt.ads (Heap_Size): New global variable. + * gcc-interface/utils2.c (maybe_wrap_malloc): Remove mostly redundant + TARGET_MALLOC64 check. Fix comment. + +2010-06-23 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb, exp_ch4.adb, s-rannum.ads, sem.adb, sem_ch12.adb: Minor + reformatting. Add comments. + * errout.adb (Finalize): Properly adjust warning count when deleting + continuations. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * errout.adb (Finalize): Set Prev pointers. + (Finalize): Delete continuations for deletion by warnings off(str). + * erroutc.ads: Add Prev pointer to error message structure. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem.adb (Do_Unit_And_Dependents): If the spec of the main unit is a + child unit, examine context of parent units to locate instantiated + generics whose bodies may be needed. + * sem_ch12.adb: (Mark_Context): if the enclosing unit does not have a + with_clause for the instantiated generic, examine the context of its + parents, to set Withed_Body flag, so that it can be visited earlier. + * exp_ch4.adb (Expand_N_Op_Not): If this is a VMS operator applied to + an unsigned type, use a type of the proper size for the intermediate + value, to prevent alignment problems on unchecked conversion. + +2010-06-22 Geert Bosch <bosch@adacore.com> + + * s-rannum.ads Change Generator type to be self-referential to allow + Random to update its argument. Use "in" mode for the generator in the + Reset procedures to allow them to be called from the Ada.Numerics + packages without tricks. + * s-rannum.adb: Use the self-referencing argument to get write access + to the internal state of the random generator. + * a-nudira.ads: Make Generator a derived type of + System.Random_Numbers.Generator. + * a-nudira.adb: Remove use of 'Unrestricted_Access. + Put subprograms in alpha order and add headers. + * g-mbdira.ads: Change Generator type to be self-referential. + * g-mbdira.adb: Remove use of 'Unrestricted_Access. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor reformatting + Minor code reorganization (use Nkind_In and Ekind_In). + +2010-06-22 Bob Duff <duff@adacore.com> + + * gnat1drv.adb (Gnat1drv): Remove the messages that recommend using + -gnatc when a file is compiled that we cannot generate code for, not + helpful and confusing. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * switch-m.adb (Normalize_Compiler_Switches): Process correctly + switches -gnatknn. + +2010-06-22 Paul Hilfinger <hilfinger@adacore.com> + + * s-rannum.adb: Replace constants with commented symbols. + * s-rannum.ads: Explain significance of the initial value of the data + structure. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * a-ngcoty.adb: Clarify comment. + +2010-06-22 Gary Dismukes <dismukes@adacore.com> + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set): Return without + expansion for indexing packed arrays with small power-of-2 component + sizes when the target is AAMP. + (Expand_Packed_Element_Reference): Return without expansion for + indexing packed arrays with small power-of-2 component sizes when the + target is AAMP. + +2010-06-22 Geert Bosch <bosch@adacore.com> + + * exp_ch4.adb (Expand_N_In): Do not substitute a valid check for X in + Float'Range. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * g-mbdira.adb, g-mbflra.adb, a-nuflra.adb, a-nudira.adb: Minor comment + updates. + +2010-06-22 Doug Rupp <rupp@adacore.com> + + * system-vms.ads, system-vms-zcx.ads: Remove old unused VMS system + packages. + * system-vms_64.ads, system-vms-ia64.ads: Minor reformatting. + (pragma Ident): Add a default ident string in the private part. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * cstand.adb: Minor reformatting. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Build_And_Analyze_Renamed_Body): For expansion purposes, + recognize the Shift and Rotation intrinsics that are known to the + compiler but have no interface name. + +2010-06-22 Geert Bosch <bosch@adacore.com> + + * a-ngcoty.adb ("*"): Rewrite complex multiplication to use proper + scaling in case of overflow or NaN results. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * cstand.adb: Complete previous change. + * g-dirope.ads: Add comment. + * s-stchop.adb, sfn_scan.adb: Minor reformatting. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * cstand.adb: Add tree nodes for pragma Pack on string types. + +2010-06-22 Javier Miranda <miranda@adacore.com> + + * einfo.ads, einfo.adb (Last_Formal): New synthesized attribute. + * exp_util.adb (Find_Prim_Op): Use new attribute to locate the last + formal of a primitive. + * exp_disp.adb (Is_Predefined_Dispatching_Operation, + Is_Predefined_Dispatching_Alias): Use new attribute to locate the last + formal of a primitive. + * exp_cg.adb (Is_Predefined_Dispatching_Operation): Use new attribute + to obtain the last formal of a primitive. + +2010-06-22 Geert Bosch <bosch@adacore.com> + + * sysdep.c, init.c, adaint.c, cstreams.c: Remove conditional code + depending on __EMX__ or MSDOS being defined. + * i-cstrea.ads, gnat_rm.texi: Remove mentions of OS/2, DOS and Xenix. + * a-excpol-abort.adb: Update comment indicating users of the file. + * xref_lib.adb, sfn_scan.adb: Remove mention of OS/2, replace NT by + Windows. + * env.c: Remove empty conditional for MSDOS. + * s-stchop.adb, g-dirope.ads, s-fileio.adb, osint.ads: Remove mention + of OS/2 in comment. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * s-rannum.adb: Minor reformatting. + +2010-06-22 Javier Miranda <miranda@adacore.com> + + * sem_aux.adb, sem_aux.ads, sem_util.adb, sem_util.ads, sem_elim.adb, + exp_cg.adb: Minor code reorganization: Move routine Ultimate_Alias from + package Sem_Util to package Sem_Aux. + +2010-06-22 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Make_Secondary_DT, Make_DT): Minor code cleanup: + remove useless restriction on imported routines when building the + dispatch tables. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * cstand.adb (Create_Standard): Set Has_Pragma_Pack for standard string + types. + +2010-06-22 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles + generic subprogram declarations to ensure proper context. Add missing + support for generic actuals. + (Try_Primitive_Operation): Add missing support for concurrent types that + have no Corresponding_Record_Type. Required to diagnose errors compiling + generics or when compiling with no code generation (-gnatc). + * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build + the corresponding record type. + * sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete + documentation. Do minimum decoration when processing a primitive of a + concurrent tagged type that covers interfaces. Required to diagnose + errors in the Object.Operation notation compiling generics or under + -gnatc. + * exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing + propagation of attribute Interface_List to the corresponding record. + (Expand_N_Task_Type_Declaration): Code cleanup. + (Expand_N_Protected_Type_Declaration): Code cleanup. + +2010-06-22 Matthew Heaney <heaney@adacore.com> + + * a-convec.adb, a-coinve.adb: Removed 64-bit types Int and UInt. + +2010-06-22 Paul Hilfinger <hilfinger@adacore.com> + + * s-rannum.adb (Random_Float_Template): Replace with unbiased version + that is able to produce all representable floating-point numbers in the + unit interval. Remove template parameter Shift_Right, no longer used. + * gnat_rm.texi: Document the period of the pseudo-random number + generator under the description of its algorithm. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * exp_aggr.adb (Rewrite_Discriminant): Fix predicate used to identify + reference to discriminant (can be an expanded name as well as an + identifier). + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb: Clarify comment. + +2010-06-22 Geert Bosch <bosch@adacore.com> + + * exp_imgv.adb (Expand_Image_Attribute): Treat ordinary fixed point + with decimal small as decimal types, avoiding floating-point arithmetic. + (Has_Decimal_Small): New function. + * einfo.ads, einfo.adb (Aft_Value): New synthesized attributed for + fixed point types. + * sem_attr.adb (Eval_Attribute): Remove Aft_Value function and update + callers to call the new function in Einfo that takes the entity as + parameter. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, sem_ch8.adb: Minor reformatting. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_elab.adb: Minor reformatting. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * gnatsym.adb: Put the object files in the table in increasing + aphabetical order of base names. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Set_Entity_Or_Discriminal): New procedure used by + Find_Direct_Name and Find_Expanded_Name, to replace a discriminant with + the corresponding discriminal within a record declaration. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * exp_aggr.adb (Rewrite_Discriminant): Rewriting must occur only for an + expression referring to a discriminal of the type of the aggregate (not + a discriminal of some other unrelated type), and the prefix in the + generated selected component must come from Lhs, not Obj. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): Fix predicate determining + when to freeze the parent type. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * s-rannum.adb, a-nudira.adb, types.ads, freeze.adb, sem_aggr.adb, + exp_aggr.adb: Minor reformatting. + * gnat_rm.texi: Document GNAT.MBBS_Discrete_Random and + GNAT.MBSS_Float_Random. + * g-mbdira.adb, g-mbflra.adb, g-mbdira.ads, g-mbflra.ads: Fix header. + +2010-06-22 Paul Hilfinger <hilfinger@adacore.com> + + * a-nudira.adb, a-nudira.ads, a-nuflra.adb, a-nuflra.ads, + gnat_rm.texi, impunit.adb, Makefile.rtl, s-rannum.adb + (Random_Float_Template, Random): New method of creating + uniform floating-point variables that allow the creation of all machine + values in [0 .. 1). + + * g-mbdira.adb, g-mbflra.adb, g-mbdira.ads, g-mbflra.ads: New file. + +2010-06-22 Gary Dismukes <dismukes@adacore.com> + + * sem_ch5.adb (Analyze_Assignment): Revise test for illegal assignment + to abstract targets to check that the type is tagged and comes from + source, rather than only testing for targets of interface types. Remove + premature return. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * vms_data.ads: Modify the declarations of qualifiers + /UNCHECKED_SHARED_LIB_IMPORTS to allow the generation of gnat.hlp + without error. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Is_Build_In_Place_Function): Predicate is false if + expansion is disabled. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * makeusg.adb: Minor reformatting. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * types.ads: (Dint): Removed, no longer used anywhere. + * uintp.adb (UI_From_CC): Use UI_From_Int, range is sufficient. + (UI_Mul): Avoid use of UI_From_Dint. + (UI_From_Dint): Removed, not used. + * uintp.ads (UI_From_Dint): Removed, not used. + (Uint_Min/Max_Simple_Mul): New constants. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * clean.adb (Parse_Cmd_Line): Recognize switch + --unchecked-shared-lib-imports. + (Usage): Add line for switch --unchecked-shared-lib-imports + * makeusg.adb: Add line for switch --unchecked-shared-lib-imports + * makeutl.ads: (Unchecked_Shared_Lib_Imports): New constant string + moved from GPR_Util. + * switch-m.adb (Scan_Make_Switches): Recognize switch + --unchecked-shared-lib-imports. + * vms_data.ads: Add VMS qualifiers /UNCHECKED_SHARED_LIB_IMPORTS. + * gnat_ugn.texi: Add documentation for new switch + --unchecked-shared-lib-imports. Add also documentation for --subdirs. + +2010-06-22 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb, sem_util.adb, sem_util.ads, sem_attr.adb, exp_ch6.adb, + exp_disp.adb, sem_eval.adb, exp_dist.adb lib-xref.adb: Code cleanup, + this patch replaces duplication of code that traverses the chain of + aliased primitives by a call to routine Ultimate_Alias that + provides this functionality. + +2010-06-22 Arnaud Charlet <charlet@adacore.com> + + * fmap.adb, opt.ads, osint.adb, osint.ads, output.ads, scng.adb, + sinput-c.adb, switch-m.ads, tree_io.ads: Use simpler form of + Warnings Off/On. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * einfo.ads: Minor reformatting. + +2010-06-22 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Expand_Interface_Thunk): Do not generate thunk of + eliminated primitives. + (Make_DT): Avoid referencing eliminated primitives. + (Register_Primitive): Do not register eliminated primitives in the + dispatch table. Required to add this functionality when the program is + compiled without static dispatch tables (-gnatd.t) + +2010-06-22 Emmanuel Briot <briot@adacore.com> + + * fmap.adb, scng.adb, switch-m.ads, sinput-c.adb, opt.ads, output.ads, + tree_io.ads, osint.adb, osint.ads: Use configuration pragmas to prevent + warnings on use of internal GNAT units. + +2010-06-22 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-vxworks.adb (Set_Priority): Update comments. + +2010-06-22 Paul Hilfinger <hilfinger@adacore.com> + + * s-rannum.adb: Make stylistic change to remove mystery constant in + Extract_Value. Image_Numeral_Length: new symbolic constant. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * einfo.ads, einfo.adb: Make Is_Protected_Interface, + Is_Synchronized_Interface, Is_Task_Interface into computable + predicates, to free three flags in entity nodes. + * sem_ch3.adb: Remove setting of these flags. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * uintp.adb, osint.adb, prj-conf.adb, prj-part.adb, prj.adb: Minor + reformatting. + * s-taprop-vxworks.adb: Add comment for Set_Priority. + * impunit.adb (Map_Array): Add entries for s-htable.ads and s-crc32.ads + * projects.texi: Move @cindex to the left margin, since otherwise we + are missing entries in the index. + +2010-06-22 Emmanuel Briot <briot@adacore.com> + + * prj-part.adb, prj.adb, tempdir.ads, makeutl.adb: Use + packages from the GNAT hierarchy instead of System when possible. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-vxworks.adb (Set_Priority): Remove the code that was + previously in place to reorder the ready queue when a task drops its + priority due to the loss of inherited priority. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * projects.texi: Minor spelling error fixes. + Minor reformatting. + +2010-06-22 Emmanuel Briot <briot@adacore.com> + + * prj-part.adb, prj-ext.adb, prj.adb, makeutl.adb, prj-conf.adb: Remove + warnings for some with clauses. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * errout.adb (Unwind_Internal_Type): Improve handling of First_Subtype + test to catch more cases where first subtype is the results we want. + * sem_res.adb (Make_Call_Into_Operator): Don't go to First_Subtype in + error case, since Errout will now handle this correctly. + * gcc-interface/Make-lang.in: Add Sem_Aux to list of GNATBIND objects. + Update dependencies. + +2010-06-22 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb (Expand_Allocator_Expression): Set Related_Node properly + when calling Make_Temporary. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Access_Subprogram_Declaration): An anonymous access to + subprogram can be associated with an entry body. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * scos.ads: Add note on membership test handling. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * projects.texi: Minor spelling fixes. + Minor reformatting. + +2010-06-22 Paul Hilfinger <hilfinger@adacore.com> + + * s-rannum.adb: Correct off-by-one error in Extract_Value. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * mlib-prj.adb (Display): In non verbose mode, truncate after fourth + argument. + * mlib-utl.adb (Gcc): In non verbose mode, truncate the display of the + gcc command if it is too long. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * errout.adb (Set_Msg_Node): Fix incorrect reference to node. + +2010-06-22 Arnaud Charlet <charlet@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Use Actual as the related node when + calling Make_Temporary. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_res.adb, sem_aux.adb, errout.adb: Minor reformatting. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb: Additional special-case for VMS. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * gnatsym.adb: Minor comment fix. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Process_Naming_Scheme): Initialize table Lib_Data_Table. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * par-ch4.adb (P_Name): Recognize 'Mod attribute in Ada 95 mode + * sem_attr.adb (Attribute_05): Add Name_Mod so that 'Mod recognized in + Ada 95 mode as an implementation defined attribute. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * bindusg.adb (Display): Update line for -R + * switch-b.adb (Scan_Binder_Switches): Allow generation of the binder + generated files when -R is used. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Lib_Data_Table): New table. + (Check_Library_Attributes): Check if the same library name is used in + two different projects that do not extend each other. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * lib-writ.ads, errout.adb, einfo.adb, einfo.ads: Minor reformatting. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * adaint.c (__gnat_locate_regular_file): If a directory in the path is + empty, make it the current working directory. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_ch3.adb (Build_Derived_Record_Type): When deriving a tagged + private type with discriminants, make sure the parent type is frozen. + +2010-06-22 Eric Botcazou <ebotcazou@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference) <Attribute_Bit>: Deal + with packed array references specially. + * exp_ch4.adb (Expand_N_Indexed_Component): Do not convert a reference + to a component of a bit packed array if it is the prefix of 'Bit. + * exp_pakd.ads (Expand_Packed_Bit_Reference): Declare. + * exp_pakd.adb (Expand_Packed_Bit_Reference): New procedure. Expand a + 'Bit reference, where the prefix involves a packed array reference. + (Get_Base_And_Bit_Offset): New helper, extracted from... + (Expand_Packed_Address_Reference): ...here. Call above procedure to + get the outer object and offset expression. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * exp_attr.adb, lib-writ.ads, bindgen.adb: Minor reformatting. + * einfo.adb (Related_Expression, Set_Related_Expression): Add + assertions. + +2010-06-22 Javier Miranda <miranda@adacore.com> + + * sem_ch3.adb (Add_Internal_Interface_Entities): Minor code + reorganization to properly check if the operation has been inherited as + an abstract operation. + +2010-06-22 Ed Falis <falis@adacore.com> + + * s-osinte-vxworks.ads: Complete previous change. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb: Add comment. + * projects.texi, gnat_ugn.texi: Remove macro. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * prj-attr.adb: Remove project level attribute Main_Language. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * switch-b.adb, osint-b.adb: Minor reformatting. + +2010-06-22 Pascal Obry <obry@adacore.com> + + * g-socthi-mingw.adb (C_Sendmsg): Do not attempt to send data from a + vector if previous send was not fully successful. If only part of + the vector data was sent, we exit the loop. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb (Make_Call_Into_Operator): Use First_Subtype for better + error reporting with generic types. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * bindgen.adb, bindusg.adb, gnatbind.adb, gnat_ugn.texi, opt.ads, + osint-b.adb, osint-b.ads, output.adb, output.ads, switch-b.adb, + vms_data.ads: Add a new command line switch -A to gnatbind to output + the list of all ALI files for the partition. + +2010-06-22 Arnaud Charlet <charlet@adacore.com> + + * s-osinte-vxworks.ads: Fix casing. + * s-vxwext-kernel.ads, s-vxwext-rtp.ads: Complete previous + change: Interfaces.C does not provide a long_long type. + +2010-06-22 Emmanuel Briot <briot@adacore.com> + + * gnat_ugn.texi, projects.texi: Preprocess projects.texi for VMS and + native user's guide, since this document contains the two versions. + * gcc-interface/Make-lang.in: Update doc dependencies. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb: Minor reformatting. Minor code reorganization. + +2010-06-22 Emmanuel Briot <briot@adacore.com> + + * gnat_ugn.texi, projects.texi: Remove toplevel menu, since we should + not build this file on its own (only through gnat_ugn.texi). + Remove macro definitions and insert simpler version in gnat_ugn.texi. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * ali-util.ads: Minor comment update. + * g-socthi-mingw.adb: Minor reformatting. + +2010-06-22 Ed Falis <falis@adacore.com> + + * s-osinte-vxworks.ads: take sigset_t definition from System.VxWorks.Ext + * s-vxwext.ads, s-vxwext-kernel.ads, s-vxwext-rtp.ads: Define sigset_t + for specific versions of VxWorks. + +2010-06-22 Emmanuel Briot <briot@adacore.com> + + * gnat_rm.texi, gnat_ugn.texi, projects.texi: Remove all project files + related sections from user's guide and reference manual, since they + have now been merged together into a separate document (projects.texi). + This removes a lot of duplication where attributes where described + in several places. + The grammar for the project files is now in each of the sections + (packages,expressions,...) instead of being duplicates in two other + sections (one in the user's guide that contained the full grammar, + and various sections in the rm that contained extracts of the same + grammar). + Added the full list of all supported attributes, since existing lists + were incomplete + Rename "associative array" into "indexed attribute" + Remove sections that were duplicates ("External References in + Project Files" and "External Values", and "Project Extensions" + for instance). The list of valid packages in project files is now in + a single place. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Add_Internal_Interface_Entities): If + Find_Primitive_Covering_Interface does not find the operation, it may + be because of a name conflict between the inherited operation and a + local non-overloadable name. In that case look for the operation among + the primitive operations of the type. This search must succeed + regardless of visibility. + +2010-06-22 Pascal Obry <obry@adacore.com> + + * g-socthi-mingw.adb: Properly honor MSG_WAITALL in recvmsg. + (C_Recvmsg): Propely honor the MSG_WAITALL flag in Windows + recvmsg emulation. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_ch4.adb (Analyze_Conditional_Expression): Defend against + malformed tree. + * sprint.adb (Sprint_Node_Actual, case N_Conditional_Expression): Ditto. + +2010-06-22 Arnaud Charlet <charlet@adacore.com> + + * s-intman-vxworks.ads: Code clean up. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb (Resolve_Slice): When the prefix is an explicit + dereference, construct actual subtype of designated object to generate + proper bounds checks. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * ali-util.adb, ali-util.ads, gnatbind.adb (Read_ALI): Rename to + Read_Withed_ALIs, which is more descriptive. + +2010-06-22 Pascal Obry <obry@adacore.com> + + * g-sothco.ads: Minor reformatting. + * g-socthi-mingw.adb: Remove part of work on the C_Recvmsg and + C_Sendmsg implementation. + (C_Sendmsg): Do not use lock (not needed). + (C_Recvmsg): Likewise and also do not wait for incoming data. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * uintp.adb: Fix scope error in operator call. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * makeutl.adb (Executable_Prefix_Path): on VMS, return "/gnu/". + * prj-conf.adb (Get_Or_Create_Configuration_File): On VMS, if + autoconfiguration is needed, fail indicating that no config project + file can be found, as there is no autoconfiguration on VMS. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Make_Call_Into_Operator): Diagnose an incorrect scope + for an operator in a functional notation, when operands are universal. + +2010-06-22 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_aggr.adb (Resolve_Record_Aggregate): Do style check on component + name. + * sem_ch10.adb (Analyze_Subunit): Do style check on parent unit name. + * sem_ch8.adb (Find_Direct_Name): For non-overloadable entities, do + style check. + * sem_res.adb (Resolve_Entity_Name): Do style check for enumeration + literals. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * make.adb (Scan_Make_Arg): No longer pass -nostdlib to the compiler as + it has no effect. Always pass -nostdlib to gnatlink, even on VMS. + +2010-06-22 Pascal Obry <obry@adacore.com> + + * g-socthi-mingw.adb: Fix implementation of the vectored sockets on + Windows. + (C_Recvmsg): Make sure the routine is atomic. Also fully + fill vectors in the proper order. + (C_Sendmsg): Make sure the routine is atomic. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_ch8.adb: Update comment. + * sem_res.adb: Minor code reorganization (use Ekind_In). + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Add_Implicit_Operator): If the context of the expanded + name is a call, use the number of actuals to determine whether this is + a binary or unary operator, rather than relying on later information + to resolve the overload. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_ch10.adb, sem_aggr.adb: Minor reformatting. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, sem_disp.adb: Minor code fixes. + * sem_eval.adb: Minor reformatting. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * make.adb (Scan_Make_Arg): When invoked with -nostdlib, pass -nostdlib + to gnatlink, except on Open VMS. + * osint.adb (Add_Default_Search_Dirs): Do not suppress the default + object directories if -nostdlib is used. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_util.adb (Is_Delegate): Put in proper alpha order. + * sem_eval.adb: Minor reformatting. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * g-expect-vms.adb, sem_res.adb: Minor reformatting. + * exp_aggr.adb: Minor comment changes and reformatting. + * sem_eval.adb (Find_Universal_Operator_Type): Put in proper alpha order + * sem_util.ads: Add some missing pragma Inline's (efficiency issue only) + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb (Build_Actual_Subtype): Record original expression in + Related_Expression attribute of the constructed subtype. + * einfo.adb, einfo.ads (Underlying_View): Move to Node28 to free up + Node24 on types for... + (Related_Expression): Make attribute available on types as well. + +2010-06-22 Gary Dismukes <dismukes@adacore.com> + + * exp_util.adb (Find_Interface_ADT): Retrieve Designated_Type instead of + Directly_Designated_Type when the type argument is an access type. + (Find_Interface_Tag): Retrieve Designated_Type instead of + Directly_Designated_Type when the type argument is an access type. + (Has_Controlled_Coextensions): Retrieve Designated_Type instead of + Directly_Designated_Type of each access discriminant. + * sem_res.adb (Resolve_Type_Conversion): Retrieve Designated_Type + instead of Directly_Designated_Type when the operand and target types + are access types. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * exp_aggr.adb (Flatten): Return False if one choice is statically + known to be out of bounds. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Call): If the call is rewritten as an indexed of + a parameterless function call, preserve parentheses of original + expression, for proper handling by pretty printer. + * sem_attr.adb (Analyze_Attribute, case 'Old): Add guard to Process + procedure, to handle quietly identifiers that have no entity names. + * exp_util.adb (Get_Current_Value_Condition): If the parent of an + elsif_part is missing, it has been rewritten as a nested if, and there + is no useful information on the current value of the variable. + +2010-06-22 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Build_Discriminal): Set default scopes for newly created + discriminals to the current scope. + * sem_util.adb (Find_Body_Discriminal): Remove setting of discriminal's + scope, which could overwrite a different already set value. + +2010-06-22 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Valid_Conversion): If expression is a predefined + operator, use sloc of type of interpretation to improve error message + when operand is of some derived type. + * sem_eval.adb (Is_Mixed_Mode_Operand): New function, use it. + +2010-06-22 Emmanuel Briot <briot@adacore.com> + + * g-expect-vms.adb (Expect_Internal): No longer raises an exception, so + that it can set out parameters as well. When a process has died, reset + its Input_Fd to Invalid_Fd, so that when using multiple processes we + can find out which process has died. + +2010-06-22 Thomas Quinot <quinot@adacore.com> + + * sem_eval.adb (Find_Universal_Operator_Type): New + subprogram to identify the operand type of an operator on universal + operands, when an explicit scope indication is present. Diagnose the + case where such a call is ambiguous. + (Eval_Arithmetic_Op, Eval_Relational_Op, Eval_Unary_Op): + Use the above to identify the operand type so it can be properly frozen. + * sem_res.adb (Make_Call_Into_Operator): Remove bogus freeze of operand + type, done in an arbitrary, possibly incorrect type (the presence of + some numeric type in the scope is checked for legality, but when more + than one such type is in the scope, we just pick a random one, not + necessarily the expected one). + * sem_utils.ads, sem_utils.adb (Is_Universal_Numeric_Type): New utility + subprogram. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * sem_eval.adb: Minor reformatting. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Expand_N_Conditional_Expression): Use + Expression_With_Actions to clean up the code generated when folding + constant expressions. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * g-expect-vms.adb: Add new subprograms Free, First_Dead_Process and + Has_Process. + +2010-06-22 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Find_Sources): When a source from a multi-unit file is + found, check if it's path has aready been found, whatever its index. + +2010-06-22 Robert Dewar <dewar@adacore.com> + + * atree.adb, gnatbind.adb: Minor reformatting. + Minor code reorganization. + +2010-06-21 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Expand_N_Conditional_Expression): Fold if condition + known at compile time. + +2010-06-21 Gary Dismukes <dismukes@adacore.com> + + * atree.adb: Fix comment typo. + +2010-06-21 Ed Schonberg <schonberg@adacore.com> + + * sem_eval.adb (Test_Ambiguous_Operator): New procedure to check + whether a universal arithmetic expression in a conversion, which is + rewritten from a function call with an expanded name, is ambiguous. + +2010-06-21 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Name_Location): New Boolean component Listed, to record + source files in specified list of sources. + (Check_Package_Naming): Remove out parameters Bodies and Specs, as they + are never used. + (Add_Source): Set the Location of the new source + (Process_Exceptions_File_Based): Call Add_Source with the Location + (Get_Sources_From_File): If an exception is found, set its Listed to + True + (Find_Sources): When Source_Files is specified, if an exception is + found, set its Listed to True. Remove any exception that is not in a + specified list of sources. + * prj.ads (Source_Data): New component Location + +2010-06-21 Vincent Celier <celier@adacore.com> + + * gnatbind.adb (Closure_Sources): Global table, moved from block. + +2010-06-21 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb: Minor reformatting. + * atree.adb: New debugging hook "rr" for node rewrites. + +2010-06-21 Robert Dewar <dewar@adacore.com> + + * g-expect.ads, g-expect.adb: Minor reformatting. + +2010-06-21 Emmanuel Briot <briot@adacore.com> + + * s-regpat.adb (Next_Pointer_Bytes): New named constant. Code clean up. + +2010-06-21 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-21 Thomas Quinot <quinot@adacore.com> + + * bindgen.ads: Update comments. + +2010-06-21 Vincent Celier <celier@adacore.com> + + * gnatbind.adb: Suppress dupicates when listing the sources in the + closure (switch -R). + +2010-06-21 Emmanuel Briot <briot@adacore.com> + + * s-regpat.adb (Link_Tail): Fix error when size of the pattern matcher + is too small. + +2010-06-21 Emmanuel Briot <briot@adacore.com> + + * g-expect.adb, g-expect.ads (First_Dead_Process, Free, Has_Process): + New subprograms. + (Expect_Internal): No longer raises an exception, so that it can set + out parameters as well. When a process has died, reset its Input_Fd + to Invalid_Fd, so that when using multiple processes we can find out + which process has died. + +2010-06-21 Robert Dewar <dewar@adacore.com> + + * s-regpat.adb, s-tpoben.adb, sem_attr.adb, sem_util.adb, sem_util.ads, + checks.adb, sem_res.adb: Minor reformatting. Add comments. + +2010-06-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (New_Overloaded_Entity): If the new entity is a + rederivation associated with a full declaration in a private part, and + there is a partial view that derives the same parent subprogram, the + new entity does not become visible. This check must be applied to + interface operations as well. + +2010-06-21 Thomas Quinot <quinot@adacore.com> + + * checks.adb: Add comments. + * prj-nmsc.adb: Minor reformatting. + +2010-06-21 Thomas Quinot <quinot@adacore.com> + + * sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb, + sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to + extract bounds, to ensure that we get the proper captured values, + rather than an expression that may have changed value since the point + where the subtype was elaborated. + (Find_Body_Discriminal): New utility subprogram to share code between... + (Eval_Attribute): For the case of a subtype bound that references a + discriminant of the current concurrent type, insert appropriate + discriminal reference. + (Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a + requeue to an entry in a family in the current task, use corresponding + body discriminal. + (Analyze_Accept_Statement): Rely on expansion of attribute references + to insert proper discriminal references in range check for entry in + family. + +2010-06-21 Emmanuel Briot <briot@adacore.com> + + * s-regpat.adb (Compile): Fix handling of big patterns. + +2010-06-21 Robert Dewar <dewar@adacore.com> + + * a-tifiio.adb: Minor reformatting. + +2010-06-21 Pascal Obry <obry@adacore.com> + + * prj-nmsc.adb (Search_Directories): Use the non-translated directory + path to open it. + +2010-06-21 Javier Miranda <miranda@adacore.com> + + * exp_cg.adb (Write_Call_Info): Fill the component sourcename using the + external name. + +2010-06-21 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Expand_Concatenate): If an object declaration is created + to hold the result, indicate that the target of the declaration does + not need an initialization, to prevent spurious errors when + Initialize_Scalars is enabled. + +2010-06-21 Ed Schonberg <schonberg@adacore.com> + + * a-tifiio.adb (Put): In the procedure that performs I/O on a String, + Fore is not bound by line length. The Fore parameter of the internal + procedure that performs the operation is an integer. + +2010-06-21 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb, checks.adb: Minor reformatting. + +2010-06-21 Emmanuel Briot <briot@adacore.com> + + * s-regpat.adb (Next_Instruction, Get_Next_Offset): Removed, merged + into Get_Next. + (Insert_Operator_Before): New subprogram, avoids duplicated code + (Compile): Avoid doing two compilations when the pattern matcher ends + up being small. + +2010-06-21 Emmanuel Briot <briot@adacore.com> + + * s-regpat.adb: Improve debug traces + (Dump): Change output format to keep it smaller. + +2010-06-21 Javier Miranda <miranda@adacore.com> + + * exp_cg.adb (Generate_CG_Output): Disable redirection of standard + output to the output file when this routine completes its work. + +2010-06-20 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Use while instead of + for loop. Call build_constructor_from_list directly in the CICO case. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Build_And_Analyze_Renamed_Body): If the renaming + declaration appears in the same unit and ealier than the renamed + entity, retain generated body to prevent order-of-elaboration issues in + gigi. + +2010-06-18 Arnaud Charlet <charlet@adacore.com> + + * s-tpoben.adb: Update comments. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * debug.adb: Minor comment change. + +2010-06-18 Javier Miranda <miranda@adacore.com> + + * exp_cg.adb: Code clean up. + * debug.adb: Complete documentation of switch -gnatd.Z. + * gcc-interface/misc.c (callgraph_info_file): Declare. + +2010-06-18 Javier Miranda <miranda@adacore.com> + + * exp_cg.adb (Homonym_Suffix_Length): Minor code reorganization. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * sprint.ads: Minor reformatting. + * output.ads: Update obsolete comment. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Build_And_Analyze_Renamed_Body): if the renamed entity is + an external intrinsic operation (e.g. a GCC numeric function) indicate + that the renaming entity has the same characteristics, so a call to it + is properly expanded. + +2010-06-18 Javier Miranda <miranda@adacore.com> + + * exp_cg.adb, exp_cg.ads, exp_disp.adb, gnat1drv.adb: Add initial + support for dispatch table/callgraph info generation. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb: Minor reformatting. + * gnatname.adb: Add comment. + +2010-06-18 Vincent Celier <celier@adacore.com> + + * gnatname.adb (Scan_Args): When --and is used, make sure that the + dynamic tables in the newly allocated Argument_Data are properly + initialized. + +2010-06-18 Eric Botcazou <ebotcazou@adacore.com> + + * gnat1drv.adb: Fix comment. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Inlined_Call): If the inlined subprogram is a + renaming, re-expand the call with the renamed subprogram if that one + is marked inlined as well. + +2010-06-18 Gary Dismukes <dismukes@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Enable + Use_Expression_With_Actions for AAMP and VM targets. + +2010-06-18 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Process_Linker): Recognize response file format GCC. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * exp_ch4.adb: Minor reformatting. + +2010-06-18 Javier Miranda <miranda@adacore.com> + + * debug.ads Add documentation on -gnatd.Z. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * sem_elim.adb: Proper error message on improperly eliminated instances + +2010-06-18 Vincent Celier <celier@adacore.com> + + * prj.ads (Response_File_Format): New value GCC. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * gnat1drv.adb: Minor reformatting. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * make.adb, sem_cat.adb: Minor reformatting. + * sem_eval.adb: Fix typos. + +2010-06-18 Pascal Obry <obry@adacore.com> + + * prj-nmsc.adb: Fix source filenames casing in debug output. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * gnatcmd.adb: Minor reformatting. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * sem_eval.adb (Eval_Conditional_Expression): Result is static if + condition and both sub-expressions are static (and result is selected + expression). + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * g-pehage.adb: Minor reformatting + +2010-06-18 Pascal Obry <obry@adacore.com> + + * prj-nmsc.adb (Search_Directories): Insert canonical filenames into + source hash table. + +2010-06-18 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update + dependencies. Fix target pairs on darwin. + (gnatlib-sjlj, gnatlib-zcx): Pass THREAD_KIND. + +2010-06-18 Pascal Obry <obry@adacore.com> + + * make.adb, prj-nmsc.adb: Fix source filenames casing in debug output. + +2010-06-18 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb: For gnatcheck, add -gnatec= switch for a global + configuration pragmas file and, if -U is not used, for a local one. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * sem_elim.adb (Check_Eliminated): Use full information on entity name + when it is given in the pragma by a selected component. + (Check_For_Eliminated_Subprogram): Do no emit error if within a + instance body that is itself within a generic unit. + * sem_ch12.adb (Analyze_Subprogram_Instance): If the subprogram is + eliminated, mark as well the anonymous subprogram that is its alias + and appears within the wrapper package. + +2010-06-18 Bob Duff <duff@adacore.com> + + * g-pehage.ads, g-pehage.adb (Produce): Clean up some of the code. + Raise an exception if the output file cannot be opened. Add comments. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * sem_cat.adb (Validate_Object_Declaration): A variable declaration is + not illegal per E.2.2(7) if it occurs in the private part of a + Remote_Types unit. + +2010-06-18 Arnaud Charlet <charlet@adacore.com> + + * par-ch9.adb, sem_aggr.adb, sem_ch3.adb, layout.adb, sem_ch4.adb, + sem_ch5.adb, sem_mech.adb, exp_util.adb, par-ch10.adb, sem_ch6.adb, + par-ch11.adb, sem_ch7.adb, par-prag.adb, exp_disp.adb, par-ch12.adb, + sem_ch8.adb, style.adb, sem_ch9.adb, sem_ch10.adb, prep.adb, + sem_warn.adb, par-util.adb, scng.adb, sem_eval.adb, checks.adb, + sem_prag.adb, sem_ch12.adb, styleg.adb, sem_ch13.adb, par-ch3.adb, + par-tchk.adb, freeze.adb, sfn_scan.adb, par-ch4.adb, sem_util.adb, + sem_res.adb, par-ch5.adb, lib-xref.adb, sem_attr.adb, par-ch6.adb, + sem_disp.adb, prepcomp.adb, par-ch7.adb, sem_elab.adb, exp_ch4.adb, + errout.ads: Update comments. Minor reformatting. + + * g-spipat.adb, a-swunau.adb, a-swunau.ads, g-spitbo.adb, + a-szunau.adb, a-szunau.ads, a-stunau.adb, a-stunau.ads, + a-strunb.adb (Big_String. Big_String_Access): New type. + + * par-labl.adb, restrict.adb, s-osinte-hpux-dce.ads, sem_ch11.adb, + exp_pakd.adb, s-filofl.ads, par-endh.adb, exp_intr.adb, sem_cat.adb, + sem_case.adb, exp_ch11.adb, s-osinte-linux.ads: Fix copyright notices. + +2010-06-18 Geert Bosch <bosch@adacore.com> + + * i-forbla-darwin.adb: Include -lgnala and -lm in linker options for + Darwin. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Set Use_Expression_With_Actions + true for gcc. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * sprint.adb: Minor format change for N_Expression_With_Actions. + * repinfo.adb: Minor reformatting. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * sem_elim.adb (Check_Eliminated): If within a subunit, use + Defining_Entity to obtain the name of the entity in the proper body, to + properly handle both separate packages and subprograms. + +2010-06-18 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb (Check_File): New parameter Display_Path. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb, g-socket.ads (Null_Selector): New object. + +2010-06-18 Pascal Obry <obry@adacore.com> + + * gnat_ugn.texi: Minor clarification. + +2010-06-18 Emmanuel Briot <briot@adacore.com> + + * prj-nmsc.adb (Find_Source_Dirs): Minor refactoring to avoid duplicate + code when using the project dir as the source dir. + (Search_Directories): use the normalized name for the source directory, + where symbolic names have potentially been resolved. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb (Expand_N_Conditional_Expression): Clear Actions field + when we create N_Expression_With_Actions node. + (Expand_Short_Circuit): Ditto. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * exp_util.adb: Minor reformatting. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * types.ads: Clean up obsolete comments + * tbuild.adb: Minor reformatting. + * exp_ch5.adb, sem_intr.adb, sem_ch10.adb, rtsfind.adb, s-shasto.adb, + exp_strm.adb, aa_drive.adb: Minor reformatting. + * sem_res.adb (Is_Predefined_Operator): An operator that is an imported + intrinsic with an Interface_Name denotes an imported back-end builtin, + and must be rewritten into a call, not left in the tree as an operator, + so return False in that case. + +2010-06-18 Eric Botcazou <ebotcazou@adacore.com> + + * exp_util.adb (Remove_Side_Effects): Make a copy for an allocator. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * scos.ads: Add proposed output for case expression + +2010-06-18 Jose Ruiz <ruiz@adacore.com> + + * gnat_ugn.texi: Document that, when using the RTX compiler to generate + RTSS modules, we need to use the Microsoft linker. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case + expression (cannot count on a particular branch being executed). + * exp_ch4.adb (Expand_N_Case_Expression): New procedure. + * exp_ch4.ads (Expand_N_Case_Expression): New procedure. + * exp_util.adb (Insert_Actions): Deal with proper insertion of actions + within case expression. + * expander.adb (Expand): Add call to Expand_N_Case_Expression + * par-ch4.adb Add calls to P_Case_Expression at appropriate points + (P_Case_Expression): New procedure + (P_Case_Expression_Alternative): New procedure + * par.adb (P_Case_Expression): New procedure + * par_sco.adb (Process_Decisions): Add dummy place holder entry for + N_Case_Expression. + * sem.adb (Analyze): Add call to Analyze_Case_Expression + * sem_case.ads (Analyze_Choices): Also used for case expressions now, + this is a documentation change only. + * sem_ch4.ads, sem_ch4.adb (Analyze_Case_Expression): New procedure. + * sem_ch6.adb (Fully_Conformant_Expressions): Add handling of case + expressions. + * sem_eval.ads, sem_eval.adb (Eval_Case_Expression): New procedure. + * sem_res.adb (Resolve_Case_Expression): New procedure. + * sem_scil.adb (Find_SCIL_Node): Add processing for + N_Case_Expression_Alternative. + * sinfo.ads, sinfo.adb (N_Case_Expression): New node. + (N_Case_Expression_Alternative): New node. + * sprint.adb (Sprint_Node_Actual): Add processing for new nodes + N_Case_Expression and N_Case_Expression_Alternative. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * par-ch7.adb, sem_warn.adb, types.ads, par-ch3.adb: Minor reformatting. + * gnat1drv.adb: Fix typo. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * par-prag.adb (Prag, case Style_Checks): All_Checks sets gnat style + for -gnatg. + * sem_prag.adb (Analyze_Pragma, case Style_Checks): All_Checks sets + gnat style for -gnatg. + * gnat_rm.texi: Add documentation for ALL_CHECKS in GNAT mode. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * sem_eval.adb (Test_In_Range): New subprogram, factoring duplicated + code between... + (Is_In_Range, Is_Out_Of_Range): Reimplement in terms of call to + Test_In_Range. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * sprint.adb: Minor change in output format for expression wi actions. + * par-ch3.adb: Minor code reorganization. Minor reformatting. + * sem_ch5.adb: Minor comment fix. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * debug.adb: New debug flag -gnatd.L to control + Back_End_Handles_Limited_Types. + * exp_ch4.adb (Expand_N_Conditional_Expression): Let back end handle + limited case if Back_End_Handles_Limited_Types is True. + (Expand_N_Conditional_Expression): Use N_Expression_With_Actions to + simplify expansion if Use_Expression_With_Actions is True. + * gnat1drv.adb (Adjust_Global_Switches): Set + Back_End_Handles_Limited_Types. + * opt.ads (Back_End_Handles_Limited_Types): New flag. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Rewrite_Operator_As_Call): Do not rewrite user-defined + intrinsic operator if expansion is not enabled, because in an + instantiation the original operator must be present to verify the + legality of the operation. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * exp_disp.adb, sem_ch12.adb: Minor reformatting + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * exp_util.adb (Make_Subtype_From_Expr): If the unconstrained type is + the class-wide type for a private extension, and the completion is a + subtype, set the type of the class-wide type to the base type of the + full view. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * g-socket.ads, sem_aggr.adb, einfo.ads, sem_elim.adb, + sem_intr.adb, sem_eval.adb: Minor reformatting + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * sem_type.adb (Is_Ancestor): If either type is private, examine full + view. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb, g-socket.ads (Check_Selector): Make Selector an IN + parameter rather than IN OUT. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb: Add extra guard. + +2010-06-18 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Object_Access_Level): For Ada 2005, determine the + accessibility level of a function call from the level of the innermost + enclosing dynamic scope. + (Innermost_Master_Scope_Depth): New function to find the depth of the + nearest dynamic scope enclosing a node. + +2010-06-18 Tristan Gingold <gingold@adacore.com> + + * adaint.c: Make ATTR_UNSET static as it is not used outside this file. + +2010-06-18 Thomas Quinot <quinot@adacore.com> + + * g-socket.ads: Minor reformatting. + +2010-06-18 Vincent Celier <celier@adacore.com> + + * make.adb (Must_Compile): New Boolean global variable + (Main_On_Command_Line): New Boolean global variable + (Collect_Arguments_And_Compile): Do compile if Must_Compile is True, + even when the project is externally built. + (Start_Compile_If_Possible): Compile in -aL directories if + Check_Readonly_Files is True. Do compile if Must_Compile is True, even + when the project is externally built. + (Gnatmake): Set Must_Compile and Check_Readonly_Files to True when + invoked with -f -u and one or several mains on the command line. + (Scan_Make_Arg): Set Main_On_Command_Line to True when at least one main + is specified on the command line. + +2010-06-18 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Build_Body_For_Inline): Handle extended_return_statements + * exp_ch6.adb (Expand_Inlined_Call): when possible, inline a body + containing extented_return statements. + * exp_util.adb (Make_CW_Equivalent_Type): If the root type is already + constrained, do not build subtype declaration. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component): + Warn on assigning to packed atomic component. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * sem_util.ads: Minor reformatting + * einfo.ads, einfo.adb: Minor doc clarification (scope of decls in + Expression_With_Actions). + * snames.ads-tmpl: Minor comment fix + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Diagnose_Multiple_Pragmas): New procedure + (Set_Imported): Use Import_Interface_Present to control message output + * sinfo.ads, sinfo.adb (Import_Interface_Present): New flag + * gnat_rm.texi: Document that we can have pragma Import and pragma + Interface for the same subprogram. + +2010-06-18 Robert Dewar <dewar@adacore.com> + + * lib-xref.adb (Generate_Reference): Fix bad reference to + Has_Pragma_Unreferenced (clients should always use Has_Unreferenced). + +2010-06-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (set_gnu_expr_location_from_node): New static + function. + (gnat_to_gnu) <N_Expression_With_Actions>: New case. + Use set_gnu_expr_location_from_node to set location information on the + result. + +2010-06-17 Arnaud Charlet <charlet@adacore.com> + + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Is_Atomic_Object): Predicate does not apply to + subprograms. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * gnat_rm.texi, gnat_ugn.texi: Clean up documentation on warning and + style check messages. + * sem_res.adb (Resolve_Call): Don't call + Check_For_Eliminated_Subprogram if we are analyzing within a spec + expression. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * debug.adb: Add documentation for debug flags .X and .Y + * exp_ch4.adb (Expand_Short_Circuit_Operator): Use + Use_Expression_With_Actions. + * gnat1drv.adb (Adjust_Global_Switches): Set + Use_Expression_With_Actions. + * opt.ads (Use_Expression_With_Actions): New switch. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * exp_intr.adb: Minor code reorganization (use UI_Max) + * sem_intr.adb: use underlying type to check legality. + * einfo.adb (Known_Static_Esize): False for generic types + (Known_Static_RM_Size): False for generic types + * einfo.ads (Known_Static_Esize): False for generic types + (Known_Static_RM_Size): False for generic types + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * exp_ch4.ads: Minor code reorganization (specs in alpha order). + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * debug.adb: New debug flag -gnatd.X to use Expression_With_Actions + node when expanding short circuit form with actions present for right + opnd. + * exp_ch4.adb: Minor reformatting + (Expand_Short_Circuit_Operator): Use new Expression_With_Actions node if + right opeand has actions present, and debug flag -gnatd.X is set. + * exp_util.adb (Insert_Actions): Handle case of Expression_With_Actions + node. + * nlists.adb (Prepend_List): New procedure + (Prepend_List_To): New procedure + * nlists.ads (Prepend_List): New procedure + (Prepend_List_To): New procedure + * sem.adb: Add processing for Expression_With_Actions + * sem_ch4.adb (Analyze_Expression_With_Actions): New procedure + * sem_ch4.ads (Analyze_Expression_With_Actions): New procedure + * sem_res.adb: Add processing for Expression_With_Actions. + * sem_scil.adb: Add processing for Expression_With_Actions + * sinfo.ads, sinfo.adb (N_Expression_With_Actions): New node. + * sprint.ads, sprint.adb: Add processing for Expression_With_Actions + +2010-06-17 Doug Rupp <rupp@adacore.com> + + * sem_intr.adb (Check_Intrinsic_Operator): Check that the types + involved both have underlying integer types. + * exp_intr.adb (Expand_Binary_Operator) New subprogram to expand a call + to an intrinsic operator when the operand types or sizes are not + identical. + * s-auxdec-vms_64.ads: Revert "+" "-" ops back to Address now that + 64/32 Address/Integer works. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Mark_Context): Refine placement of Withed_Body flag, so + that it marks a unit as needed by a spec only if the corresponding + instantiation appears in that spec (and not in the corresponding body). + * sem_elim.adb (Check_Eliminated): If we are within a subunit, the name + in the pragma Eliminate has been parsed as a child unit, but the + current compilation unit is in fact the parent in which the subunit is + embedded. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * gnat_rm.texi: Fix typo + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * sem_util.adb: Minor reformatting + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem.adb (Do_Withed_Unit): if the unit in the with_clause is a generic + instance, the clause now denotes the instance body. Traverse the + corresponding spec because there may be no other dependence that will + force the traversal of its own context. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch10.adb (Is_Ancestor_Unit): Subsidiary to + Install_Limited_Context_Clauses, to determine whether a limited_with in + some parent of the current unit designates some other parent, in which + case the limited_with clause must not be installed. + (In_Context): Refine test. + +2010-06-17 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Collect_Primitive_Operations): In the of an untagged + type with a dispatching equality operator that is overridden (for a + tagged full type), don't include the overridden equality in the list of + primitives. The overridden equality is detected by testing for an + Aliased field that references the overriding equality. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * freeze.adb: Minor reformatting. + +2010-06-17 Joel Brobecker <brobecker@adacore.com brobecker> + + * gnat_ugn.texi: Add a section introducing gdbserver. + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb, sem_ch4.adb, s-stoele.adb, par-labl.adb: Minor + reformatting. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_aggr.adb (Valid_Ancestor_Type): handle properly the case of a + constrained discriminated parent that is a private type. + (Analyze_Record_Aggregate): when collecting inherited discriminants, + handle properly an ancestor type that is a constrained private type. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Enclosing_Subprogram): If the called subprogram is + protected, use the protected_subprogram_body only if the original + subprogram has not been eliminated. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Expression): The designated type of an + access_to_suprogram type can only be frozen if all types in its profile + are fully defined. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * par.adb: Minor comment fix + * sem_aggr.adb, sem_ch3.adb: Minor reformatting + +2010-06-17 Doug Rupp <rupp@adacore.com> + + * s-auxdec-vms_64.ads: Revert Integer to Long_Integer change, instead + change Address to Short_Address in functions where both must be the + same size for intrinsics to work. + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * sem_ch4.adb (Analyze_Selected_Component): A selected component may + not denote a (private) component of a protected object. + +2010-06-17 Bob Duff <duff@adacore.com> + + * par-labl.adb (Try_Loop): Test whether the label and the goto are in + the same list. + +2010-06-17 Joel Brobecker <brobecker@adacore.com brobecker> + + * gnat_ugn.texi: Update the documentation about GDB re: exception + catchpoints. + +2010-06-17 Arnaud Charlet <charlet@adacore.com> + + * gnatvsn.ads: Bump to 4.6 version. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): The + designated type of the generated pointer is the type of the original + expression, not that of the function call itself, because the return + type may be an untagged derived type and the function may be an + inherited operation. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * exp_ch4.adb: Minor reformatting. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads, sinfo.adb (Inherited_Discriminant): New flag on + N_Component_Association nodes, to indicate that a component association + of an extension aggregate denotes the value of a discriminant of an + ancestor type that has been constrained by the derivation. + * sem_aggr.adb (Discr_Present): use Inherited_Discriminant to prevent a + double expansion of the aggregate appearing in a context that delays + expansion, to prevent double insertion of discriminant values when the + aggregate is reanalyzed. + +2010-06-17 Arnaud Charlet <charlet@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Do not use + Allocator as the Related_Node of Return_Obj_Access in call to + Make_Temporary below as this would create a sort of infinite + "recursion". + +2010-06-17 Ben Brosgol <brosgol@adacore.com> + + * gnat_ugn.texi: Update gnatcheck doc. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Build_Incomplete_Type_Declaration): If there is an + incomplete view of the type that is not tagged, and the full type is a + tagged extension, create class_wide type now, and warn that the + incomplete view should be tagged as well. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb (Non_VMS_Usage): Do not issue usage for gnat sync. + Update the last line of the usage, indicating what commands do not + accept project file switches. + * vms_conv.adb: Do not issue usage line for GNAT SYNC + * vms_data.ads: Fix errors in the qualifiers /LOGFILE and /MAIN of + GNAT ELIM. + * gnat_ugn.texi: Document the relaxed rules for library directories in + externally built library projects. + +2010-06-17 Doug Rupp <rupp@adacore.com> + + * s-auxdec-vms_64.ads: Make boolean and arithmetic operations intrinsic + where possible. + * s-auxdec-vms-alpha.adb: Remove kludges for aforemention. + * gcc-interface/Makefile.in: Update VMS target pairs. + +2010-06-17 Vasiliy Fofanov <fofanov@adacore.com> + + * adaint.c: Reorganized in order to avoid use of GetProcessId to stay + compatible with Windows NT 4.0 which doesn't provide this function. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * ali-util.adb (Time_Stamp_Mismatch): In Verbose mode, if there is + different timestamps but the checksum is the same, issue a short + message saying so. + +2010-06-17 Arnaud Charlet <charlet@adacore.com> + + * s-interr.adb (Finalize): If the Abort_Task signal is set to system, + it means that we cannot reset interrupt handlers since this would + require potentially sending the abort signal to the Server_Task. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb: expand NOT for VMS types. + * sem_util.adb: Use OpenVMS_On_Target for IS_VMS_Operator. + +2010-06-17 Sergey Rybin <rybin@adacore.com> + + * vms_data.ads: Add qualifier for '--no-elim-dispatch' gnatelim option. + * gnat_ugn.texi (gnatelim): add description for --no-elim-dispatch + option. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Call): Do not expand a call to an internal + protected operation if the subprogram has been eliminated. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * prj-nmsc.adb (Check_Library_Attributes): Allow the different + directories associated with a library to be any directory when the + library project is externally built. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * make.adb (Check): If switch -m is used, deallocate the memory that + may be allocated when computing the checksum. + +2010-06-17 Eric Botcazou <ebotcazou@adacore.com> + + * g-socthi-mingw.adb (C_Recvmsg): Add 'use type' clause for C.size_t; + (C_Sendmsg): Likewise. + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb: Update comments. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * back_end.adb (Scan_Compiler_Arguments): Process last argument + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * exp_ch3.adb, exp_ch6.adb, exp_smem.adb, exp_util.adb: Use Ekind_In. + * layout.adb, freeze.adb: Use Make_Temporary. + +2010-06-17 Jerome Lambourg <lambourg@adacore.com> + + * exp_ch11.adb (Expand_N_Raise_Statement): Expand raise statements in + .NET/JVM normally as this is now perfectly supported by the backend. + +2010-06-17 Pascal Obry <obry@adacore.com> + + * gnat_rm.texi: Fix minor typo, remove duplicate blank lines. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * make.adb (Collect_Arguments_And_Compile): Create include path file + only when -x is specified. + (Gnatmake): Ditto + * opt.ads (Use_Include_Path_File): New Boolean flag, initialized to + False. + * prj-env.adb (Set_Ada_Paths): New Boolean parameters Include_Path and + Objects_Path, defaulted to True. Only create include path file if + Include_Path is True, only create objects path file if Objects_Path is + True. + * prj-env.ads (Set_Ada_Paths): New Boolean parameters Include_Path and + Objects_Path, defaulted to True. + * switch-m.adb (Scan_Make_Switches): Set Use_Include_Path_File to True + when -x is used. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * exp_disp.adb (Build_Interface_Thunk): Use base type of formal to + determine whether it has the controlling type, when the formal is an + access parameter. + +2010-06-17 Eric Botcazou <ebotcazou@adacore.com> + + * s-crtl.ads (ssize_t): New type. + (read): Fix signature. + (write): Likewise. + * g-socthi.ads: Add 'with System.CRTL' clause. Remove ssize_t and + 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi.adb (Syscall_Recvmsg): Likewise. + (Syscall_Sendmsg): Likewise. + (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-mingw.ads: Add 'with System.CRTL' clause. Remove ssize_t + and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-mingw.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-vms.ads: Add 'with System.CRTL' clause. Remove ssize_t and + 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-vms.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-socthi-vxworks.ads Add 'with System.CRTL' clause. Remove ssize_t + and 'use type' directive for C.size_t, add one for System.CRTL.ssize_t. + (C_Recvmsg): Replace ssize_t with System.CRTL.ssize_t. + (C_Sendmsg): Likewise. + * g-socthi-vxworks.adb (C_Recvmsg): Likewise. + (C_Sendmsg): Likewise. + * g-sercom-linux.adb (Read): Use correct types to call 'read'. + (Write): Likewise to call 'write'. + * s-os_lib.adb (Read): Use correct type to call System.CRTL.read. + (Write): Use correct type to call System.CRTL.write. + * s-tasdeb.adb (Write): Likewise. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * prj-proc.adb (Copy_Package_Declarations): Change argument name + Naming_Restricted to Restricted. If Restricted is True, do not copy the + value of attribute Linker_Options. + +2010-06-17 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (push_stack, pop_stack): Delete. + (Case_Statement_to_gnu): Adjust. + (Loop_Statement_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (Handled_Sequence_Of_Statements_to_gnu): Likewise. + (Compilation_Unit_to_gnu): Likewise. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * exp_fixd.adb, exp_imgv.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb, + exp_sel.adb, exp_util.adb, sem_ch10.adb, sem_ch12.adb, sem_ch13.adb, + sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch8.adb, sem_ch9.adb, + sem_dist.adb, sem_util.adb: Use Make_Temporary + * itypes.ads, tbuild.ads: Minor comment update + * exp_ch9.adb, exp_dist.adb: Minor reformatting + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * exp_imgv.adb, exp_ch7.ads: Minor reformatting. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * exp_ch9.adb, exp_disp.adb, exp_dist.adb: Use Make_Temporary. + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * sprint.adb (pg): Set Dump_Freeze_Null, to be consistent with -gnatdg. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb, exp_ch7.adb, exp_ch5.adb: Use Make_Temporary + * tbuild.ads (Make_Temporary): More comment updates + * tbuild.adb: Minor reformatting + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * checks.adb, exp_aggr.adb, exp_atag.adb, exp_attr.adb, exp_ch11.adb, + exp_ch3.adb, exp_ch4.adb: Minor code reorganization. + Use Make_Temporary. + * tbuild.ads, tbuild.adb (Make_Temporary): Clean up, use Entity_Id + instead of Node_Id. + (Make_Temporary): Add more extensive documentation + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * sem_intr.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb, + sem_warn.adb, sem_eval.adb: Minor reformatting. Use Ekind_In. + (Set_Slice_Subtype): Explicitly freeze the slice's itype at the point + where the slice's actions are inserted. + (Decompose_Expr): Account for possible rewriting of slice bounds + resulting from side effects suppression caused by the above freezing, + so that folding of bounds is preserved by such rewriting. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * einfo.ads, einfo.adb (Get_Record_Representation_Clause): New function. + * freeze.adb (Freeze_Record_Type): Add call to + Check_Record_Representation_Clause. + * sem_ch13.adb (Check_Record_Representation_Clause): New function + (Analyze_Record_Representation_Clause): Split out overlap code into this + new function. + (Check_Component_Overlap): Moved inside + Check_Record_Representation_Clause. + * sem_ch13.ads (Check_Record_Representation_Clause): New function. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * back_end.adb, sem_res.adb, switch-c.adb, sem_scil.adb: Minor + reformatting. + * sem_attr.adb, sem_cat.adb, sem_disp.adb, sem_elab.adb, sem_elim.adb, + sem_eval.adb: Use Ekind_In + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb: better error message for illegal inherited discriminant + +2010-06-17 Vincent Celier <celier@adacore.com> + + * bindusg.adb: Remove lines for -A and -C + * gnat_ugn.texi: Remove all documentation and examples of switches -A + and -C for gnatbind and gnatlink. + * gnatlink.adb (Usage): Remove lines for -A and -C + * switch-b.adb (Scan_Binder_Switches): Issue warning when switch -C is + specified. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * back_end.adb (Scan_Compiler_Arguments): Put all arguments in new + local Argument_List variable Args. + * switch-c.adb (Scan_Front_End_Switches): New Argument_List argument + Args. + (Switch_Subsequently_Cancelled): New Argument_List argument Args. Look + for subsequent switches in Args. + * switch-c.ads (Scan_Front_End_Switches): New Argument_List argument + Args. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * einfo.adb: Minor code fix, allow E_Class_Wide_Type for + Equivalent_Type to match documentation. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb, sem_ch7.adb: Minor reformatting. + * sem_ch3.adb, sem_ch5.adb, sem_ch9.adb, sem_ch10.adb, sem_ch12.adb, + sem_ch4.adb, sem_ch8.adb, sem_ch13.adb: Make use of Ekind_In. + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * sem_res.adb (Set_Slice_Subtype): Always freeze the slice's itype. + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Freeze_Expression): Short circuit operators are valid + freeze node insertion points. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * switch-c.ads, switch-c.adb, sem_ch13.adb: Minor reformatting. + * sem_ch12.adb: Add pragmas Assert and Check to previous change. + +2010-06-17 Gary Dismukes <dismukes@adacore.com> + + * layout.adb (Layout_Type): Broaden test for setting an array type's + Component_Size to include all scalar types, not just discrete types + (components of real types were missed). + * sem_ch3.adb (Constrain_Index): Add missing setting of First_Literal + on the itype created for an index (consistent with Make_Index and + avoids possible Assert_Failures). + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * atree.ads, atree.adb: Add 6-parameter version of Ekind_In + * einfo.adb: Minor code reformatting (use Ekind_In) + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * sem_warn.adb (Test_Ref): Abandon scan if access subprogram parameter + found. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * back_end.adb: Minor comment updates + * switch-c.adb: Remove dependencies on gcc C sources + * gcc-interface/Make-lang.in: Add a-comlin.o to the object file list + for the compiler. + +2010-06-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb: propagate Pragma_Enabled flag to generic. + * get_scos.adb: Set C2 flag in decision entry of pragma to 'e' (enabled) + * par_sco.ads, par_sco.adb (Set_SCO_Pragma_Enabled): New procedure + Remove use of Node field in SCOs table + (Output_Header): Set 'd' to initially disable pragma entry + * put_scos.adb (Put_SCOs): New flag indicating if pragma is enabled + * scos.ads, scos.adb: Remove Node field from internal SCOs table. + Use C2 field of pragma decision header to indicate enabled. + * sem_prag.adb: Add calls to Set_SCO_Pragma_Enabled. + * gcc-interface/Make-lang.in: Update dependencies. + +2010-06-17 Vincent Celier <celier@adacore.com> + + * back_end.adb (Next_Arg): Moved to procedure Scan_Compiler_Arguments + (Scan_Compiler_Arguments): Call Scan_Front_End_Switches with Next_Arg + (Switch_Subsequently_Cancelled): Function moved to the body of Switch.C + * back_end.ads (Scan_Front_End_Switches): Function moved to the body of + Switch.C. + * switch-c.adb: Copied a number of global declarations from back_end.adb + (Len_Arg): New function copied from back_end.adb + (Switch_Subsequently_Cancelled): New function moved from back_end.adb + (Scan_Front_End_Switches): New parameter Arg_Rank used to call + Switch_Subsequently_Cancelled. + * switch-c.ads (Scan_Front_End_Switches): New parameter Arg_Rank. + * gcc-interface/Makefile.in: Add line so that shared libgnat is linked + with -lexc on Tru64. + +2010-06-17 Robert Dewar <dewar@adacore.com> + + * prj.ads, prj.adb: Minor reformatting + +2010-06-17 Thomas Quinot <quinot@adacore.com> + + * put_scos.adb: Do not generate a blank line in SCOs when omitting the + CP line for a disabled pragma. + +2010-06-17 Emmanuel Briot <briot@adacore.com> + + * prj-proc.adb, prj.adb, prj.ads (Check_Or_Set_Typed_Variable): New + subprogram. + (Process_Declarative_Item): An invalid value in an typed variable + declaration is no longer always fatal. + +2010-06-16 Arnaud Charlet <charlet@adacore.com> + + * get_scos.adb, par_sco.adb, par_sco.ads, put_scos.adb, scos.adb, + scos.ads, exp_ch4.adb, sem_warn.adb: Code clean up, update + documentation. + +2010-06-16 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Expand_Dispatching_Call): Adjust the decoration of the + node referenced by the SCIL node of dispatching "=" to skip the tags + comparison. + +2010-06-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Exit_Statement): Return if no enclosing loop, + to prevent cascaded errors and compilation aborts. + +2010-06-16 Robert Dewar <dewar@adacore.com> + + * back_end.adb (Switch_Subsequently_Cancelled): New function + Move declarations to package body level to support this change + * back_end.ads (Switch_Subsequently_Cancelled): New function + * gnat_ugn.texi: Document -gnat-p switch + * switch-c.adb (Scan_Front_End_Switches): Implement -gnat-p switch + * ug_words: Add entry for -gnat-p (UNSUPPRESS_ALL) + * usage.adb: Add line for -gnat-p switch + * vms_data.ads: Add entry for UNSUPPRESS_ALL (-gnat-p) + +2010-06-16 Robert Dewar <dewar@adacore.com> + + * sem_warn.adb (Check_Infinite_Loop_Warning): Declaration counts as + modification. + +2010-06-16 Robert Dewar <dewar@adacore.com> + + * exp_disp.adb: Minor reformatting + +2010-06-16 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Complete_Private_Subtype): Inherit class_wide type from + base type only if it was not previously created for the partial view. + +2010-06-16 Thomas Quinot <quinot@adacore.com> + + * tbuild.ads: Minor comment fix + +2010-06-15 Nathan Froyd <froydnj@codesourcery.com> + + * gcc-interface/trans.c (gnu_stack_free_list): Delete. + (gnu_except_ptr_stack): Change type to VEC. Update comment. + (gnu_elab_proc_stack): Likewise. + (gnu_return_label_stack): Likewise. + (gnu_loop_label_stack): Likewise. + (gnu_switch_label_stack): Likewise. + (gnu_constraint_label_stack): Likewise. + (gnu_storage_error_label_stack): Likewise. + (gnu_program_error_label_stack): Likewise. + (push_exception_label_stack): Take a VEC ** instead of a tree *. + (push_stack): Likewise. Remove unused second parameter. Update + callers. + (pop_stack): Take a VEC * instead of a tree *. Update callers. + (gigi): Initialize stacks as VECs. + (Identifier_to_gnu): Use VEC_last instead of TREE_VALUE. + (Case_Statement_to_gnu): Likewise. + (Subprogram_Body_to_gnu): Likewise. + (call_to_gnu): Likewise. + (Exception_Handler_to_gnu_sjlj): Likewise. + (gnat_to_gnu): Likewise. + (get_exception_label): Likewise. + 2010-06-14 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Build_Derived_Record_Type): if derived type is an diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index f101a52e025..6e7d4eba44a 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1,5 +1,5 @@ # Makefile.rtl for GNU Ada Compiler (GNAT). -# Copyright (C) 2003-2008, Free Software Foundation, Inc. +# Copyright (C) 2003-2010, Free Software Foundation, Inc. #This file is part of GCC. @@ -211,6 +211,7 @@ GNATRTL_NONTASKING_OBJS= \ a-ststio$(objext) \ a-stunau$(objext) \ a-stunha$(objext) \ + a-stuten$(objext) \ a-stwibo$(objext) \ a-stwifi$(objext) \ a-stwiha$(objext) \ @@ -225,6 +226,9 @@ GNATRTL_NONTASKING_OBJS= \ a-stzsea$(objext) \ a-stzsup$(objext) \ a-stzunb$(objext) \ + a-suenco$(objext) \ + a-suewen$(objext) \ + a-suezen$(objext) \ a-suteio$(objext) \ a-swbwha$(objext) \ a-swfwha$(objext) \ @@ -359,6 +363,8 @@ GNATRTL_NONTASKING_OBJS= \ g-io$(objext) \ g-io_aux$(objext) \ g-locfil$(objext) \ + g-mbdira$(objext) \ + g-mbflra$(objext) \ g-md5$(objext) \ g-memdum$(objext) \ g-moreex$(objext) \ diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index fb4038db259..6443644b4f6 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, 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- -- @@ -33,9 +33,6 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is - type Int is range System.Min_Int .. System.Max_Int; - type UInt is mod System.Max_Binary_Modulus; - procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -47,10 +44,22 @@ package body Ada.Containers.Indefinite_Vectors is --------- function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + N : Count_Type'Base; -- length of result + J : Count_Type'Base; -- for computing intermediate values + Last : Index_Type'Base; -- Last index of result begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the vector parameters. We could decide to make it larger, but we + -- have no basis for knowing how much larger, so we just allocate the + -- minimum amount of storage. + + -- Here we handle the easy cases first, when one of the vector + -- parameters is empty. (We say "easy" because there's nothing to + -- compute, that can potentially overflow.) + if LN = 0 then if RN = 0 then return Empty_Vector; @@ -64,6 +73,11 @@ package body Ada.Containers.Indefinite_Vectors is new Elements_Type (Right.Last); begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Right vector, and copy + -- each source element individually. + for I in Elements.EA'Range loop begin if RE (I) /= null then @@ -95,6 +109,11 @@ package body Ada.Containers.Indefinite_Vectors is new Elements_Type (Left.Last); begin + -- Elements of an indefinite vector are allocated, so we cannot + -- use simple slice assignment to give a value to our result. + -- Hence we must walk the array of the Left vector, and copy + -- each source element individually. + for I in Elements.EA'Range loop begin if LE (I) /= null then @@ -116,121 +135,161 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - declare - N : constant Int'Base := Int (LN) + Int (RN); - J : Int'Base; + -- Neither of the vector parameters is empty, so we must compute the + -- length of the result vector and its last index. (This is the harder + -- case, because our computations must avoid overflow.) - begin - -- There are two constraints we need to satisfy. The first constraint - -- is that a container cannot have more than Count_Type'Last - -- elements, so we must check the sum of the combined lengths. (It - -- would be rare for vectors to have such a large number of elements, - -- so we would normally expect this first check to succeed.) The - -- second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. - - if N > Count_Type'Pos (Count_Type'Last) then + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the combined lengths. Note that we cannot + -- simply add the lengths, because of the possibilty of overflow. + + if LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe compute the length of the new vector. + + N := LN + RN; + + -- The second constraint is that the new Last index value cannot + -- exceed Index_Type'Last. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then raise Constraint_Error with "new length is out of range"; end if; - -- We now check whether the new length would create a Last index - -- value greater than Index_Type'Last. This calculation requires - -- care, because overflow can occur when Index_Type'First is near the - -- end of the range of Int. + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - if Index_Type'First <= 0 then + Last := No_Index + Index_Type'Base (N); - -- Compute the potential Last index value in the normal way, using - -- Int as the type in which to perform intermediate - -- calculations. Int is a 64-bit type, and Count_Type is a 32-bit - -- type, so no overflow can occur. + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: - J := Int (Index_Type'First - 1) + N; + if Last > Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if J > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + elsif Index_Type'First <= 0 then - else - -- If Index_Type'First is within N of Int'Last, then overflow - -- would occur if we simply computed Last directly. So instead of - -- computing Last, and then determining whether its value is - -- greater than Index_Type'Last (as we do above), we work - -- backwards by computing the potential First index value, and - -- then checking whether that value is less than Index_Type'First. + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of length. - J := Int (Index_Type'Last) - N + 1; + J := Count_Type'Base (No_Index) + N; -- Last - if J < Int (Index_Type'First) then - raise Constraint_Error with "new length is out of range"; - end if; + if J > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (J); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - -- We have determined that Length would not create a Last index - -- value outside of the range of Index_Type, so we can now safely - -- compute its value. + J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - J := Int (Index_Type'First - 1) + N; + if J < Count_Type'Base (No_Index) then + raise Constraint_Error with "new length is out of range"; end if; - declare - Last : constant Index_Type := Index_Type (J); + -- We have determined that the result length would not create a Last + -- index value outside of the range of Index_Type, so we can now + -- safely compute its value. - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + Last := Index_Type'Base (Count_Type'Base (No_Index) + N); + end if; - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : Elements_Access := new Elements_Type (Last); + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); - I : Index_Type'Base := No_Index; + Elements : Elements_Access := new Elements_Type (Last); - begin - for LI in LE'Range loop - I := I + 1; + I : Index_Type'Base := No_Index; - begin - if LE (LI) /= null then - Elements.EA (I) := new Element_Type'(LE (LI).all); - end if; + begin + -- Elements of an indefinite vector are allocated, so we cannot use + -- simple slice assignment to give a value to our result. Hence we + -- must walk the array of each vector parameter, and copy each source + -- element individually. - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; + for LI in LE'Range loop + I := I + 1; - Free (Elements); - raise; - end; - end loop; + begin + if LE (LI) /= null then + Elements.EA (I) := new Element_Type'(LE (LI).all); + end if; - for RI in RE'Range loop - I := I + 1; + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; - begin - if RE (RI) /= null then - Elements.EA (I) := new Element_Type'(RE (RI).all); - end if; + Free (Elements); + raise; + end; + end loop; - exception - when others => - for J in Index_Type'First .. I - 1 loop - Free (Elements.EA (J)); - end loop; + for RI in RE'Range loop + I := I + 1; - Free (Elements); - raise; - end; - end loop; + begin + if RE (RI) /= null then + Elements.EA (I) := new Element_Type'(RE (RI).all); + end if; - return (Controlled with Elements, Last, 0, 0); - end; + exception + when others => + for J in Index_Type'First .. I - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + if Left.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -248,8 +307,10 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Left.Length = Count_Type'Last then @@ -306,6 +367,14 @@ package body Ada.Containers.Indefinite_Vectors is function "&" (Left : Element_Type; Right : Vector) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + if Right.Is_Empty then declare Elements : Elements_Access := new Elements_Type (Index_Type'First); @@ -323,8 +392,10 @@ package body Ada.Containers.Indefinite_Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Right.Length = Count_Type'Last then @@ -380,6 +451,17 @@ package body Ada.Containers.Indefinite_Vectors is function "&" (Left, Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last (here, we + -- know that that condition is satisfied), and the new Last index cannot + -- exceed Index_Type'Last. + if Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -572,75 +654,177 @@ package body Ada.Containers.Indefinite_Vectors is Index : Extended_Index; Count : Count_Type := 1) is - begin + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; - if Index > Container.Last then - if Index > Container.Last + 1 then + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; return; end if; + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + if Count = 0 then return; end if; + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, so we handle that case here in order to avoid having to + -- check it later. (Note that an empty vector can never be busy, so + -- there's no semantic harm in returning early.) + + if Container.Is_Empty then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - declare - Index_As_Int : constant Int := Int (Index); - Old_Last_As_Int : constant Int := Int (Container.Last); + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) - Count1 : constant Int'Base := Int (Count); - Count2 : constant Int'Base := Old_Last_As_Int - Index_As_Int + 1; - N : constant Int'Base := Int'Min (Count1, Count2); + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - J_As_Int : constant Int'Base := Index_As_Int + N; - E : Elements_Array renames Container.Elements.EA; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; - begin - if J_As_Int > Old_Last_As_Int then + -- If the number of elements requested (Count) for deletion is equal to + -- (or greater than) the number of elements available (Count2) for + -- deletion beginning at Index, then everything from Index to + -- Container.Last is deleted (this is equivalent to Delete_Last). + + if Count >= Count2 then + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in + -- order to gracefully handle deallocation failures. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin while Container.Last >= Index loop declare K : constant Index_Type := Container.Last; - X : Element_Access := E (K); + X : Element_Access := EA (K); begin - E (K) := null; + -- We first isolate the element we're deleting, removing it + -- from the vector before we attempt to deallocate it, in + -- case the deallocation fails. + + EA (K) := null; Container.Last := K - 1; + + -- Container invariants have been restored, so it is now + -- safe to attempt to deallocate the element. + Free (X); end; end loop; + end; - else - declare - J : constant Index_Type := Index_Type (J_As_Int); + return; + end if; - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - New_Last : constant Index_Type := - Index_Type (New_Last_As_Int); + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := Old_Last - Index_Type'Base (Count); + J := Index + Index_Type'Base (Count); + + else + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + J := Index_Type'Base (Count_Type'Base (Index) + Count); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so what remains to be done is to first + -- deallocate the elements that are being deleted, and then slide down + -- to Index the elements that aren't being deleted. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + -- Before we can slide down the elements that aren't being deleted, + -- we need to deallocate the elements that are being deleted. + + for K in Index .. J - 1 loop + declare + X : Element_Access := EA (K); begin - for K in Index .. J - 1 loop - declare - X : Element_Access := E (K); - begin - E (K) := null; - Free (X); - end; - end loop; + -- First we remove the element we're about to deallocate from + -- the vector, in case the deallocation fails, in order to + -- preserve representation invariants. - E (Index .. New_Last) := E (J .. Container.Last); - Container.Last := New_Last; + EA (K) := null; + + -- The element has been removed from the vector, so it is now + -- safe to attempt to deallocate it. + + Free (X); end; - end if; + end loop; + + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; end; end Delete; @@ -698,32 +882,64 @@ package body Ada.Containers.Indefinite_Vectors is (Container : in out Vector; Count : Count_Type := 1) is - N : constant Count_Type := Length (Container); - begin - if Count = 0 - or else N = 0 - then + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + + if Count = 0 then return; end if; + -- We cannot simply subsume the empty case into the loop below (the loop + -- would iterate 0 times), because we rename the internal array object + -- (which is allocated), but an empty vector isn't guaranteed to have + -- actually allocated an array. (Note that an empty vector can never be + -- busy, so there's no semantic harm in returning early here.) + + if Container.Is_Empty then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in order + -- to gracefully handle deallocation failures. + declare E : Elements_Array renames Container.Elements.EA; begin - for Indx in 1 .. Count_Type'Min (Count, N) loop + for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop declare J : constant Index_Type := Container.Last; X : Element_Access := E (J); begin + -- Note that we first isolate the element we're deleting, + -- removing it from the vector, before we actually deallocate + -- it, in order to preserve representation invariants even if + -- the deallocation fails. + E (J) := null; Container.Last := J - 1; + + -- Container invariants have been restored, so it is now safe + -- to deallocate the element. + Free (X); end; end loop; @@ -1073,22 +1289,42 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Element_Type; Count : Count_Type := 1) is - N : constant Int := Int (Count); + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch - Dst : Elements_Access; + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1096,197 +1332,371 @@ package body Ada.Containers.Indefinite_Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + 1); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately allocated. + Container.Elements := new Elements_Type (New_Last); - Container.Last := No_Index; - for J in Container.Elements.EA'Range loop - Container.Elements.EA (J) := new Element_Type'(New_Item); - Container.Last := J; + -- The element backbone has been successfully allocated, so now we + -- allocate the elements. + + for Idx in Container.Elements.EA'Range loop + -- In order to preserve container invariants, we always attempt + -- the element allocation first, before setting the Last index + -- value, in case the allocation fails (either because there is no + -- storage available, or because element initialization fails). + + Container.Elements.EA (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now safe to + -- update the Last index, restoring container invariants. + + Container.Last := Idx; end loop; return; end if; - if New_Last <= Container.Elements.Last then + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + declare E : Elements_Array renames Container.Elements.EA; + K : Index_Type'Base; begin - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. + + for Idx in Before .. New_Last loop + -- In order to preserve container invariants, we always + -- attempt the element allocation first, before setting the + -- Last index value, in case the allocation fails (either + -- because there is no storage available, or because element + -- initialization fails). + + E (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now + -- safe to update the Last index, restoring container + -- invariants. - Index : constant Index_Type := Index_Type (Index_As_Int); + Container.Last := Idx; + end loop; + + else + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. - J : Index_Type'Base; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + -- The new items are being inserted in the middle of the array, + -- in the range [Before, Index). Copy the existing elements to + -- the end of the array, to make room for the new items. + + E (Index .. New_Last) := E (Before .. Container.Last); + Container.Last := New_Last; + + -- We have copied the existing items up to the end of the + -- array, to make room for the new items in the middle of + -- the array. Now we actually allocate the new items. + + -- Note: initialize K outside loop to make it clear that + -- K always has a value if the exception handler triggers. + + K := Before; begin - -- The new items are being inserted in the middle of the - -- array, in the range [Before, Index). Copy the existing - -- elements to the end of the array, to make room for the - -- new items. - - E (Index .. New_Last) := E (Before .. Container.Last); - Container.Last := New_Last; - - -- We have copied the existing items up to the end of the - -- array, to make room for the new items in the middle of - -- the array. Now we actually allocate the new items. - - -- Note: initialize J outside loop to make it clear that - -- J always has a value if the exception handler triggers. - - J := Before; - begin - while J < Index loop - E (J) := new Element_Type'(New_Item); - J := J + 1; - end loop; + while K < Index loop + E (K) := new Element_Type'(New_Item); + K := K + 1; + end loop; - exception - when others => + exception + when others => - -- Values in the range [Before, J) were successfully - -- allocated, but values in the range [J, Index) are - -- stale (these array positions contain copies of the - -- old items, that did not get assigned a new item, - -- because the allocation failed). We must finish what - -- we started by clearing out all of the stale values, - -- leaving a "hole" in the middle of the array. + -- Values in the range [Before, K) were successfully + -- allocated, but values in the range [K, Index) are + -- stale (these array positions contain copies of the + -- old items, that did not get assigned a new item, + -- because the allocation failed). We must finish what + -- we started by clearing out all of the stale values, + -- leaving a "hole" in the middle of the array. - E (J .. Index - 1) := (others => null); - raise; - end; + E (K .. Index - 1) := (others => null); + raise; end; - - else - for J in Before .. New_Last loop - E (J) := new Element_Type'(New_Item); - Container.Last := J; - end loop; end if; end; return; end if; - -- There follows LOTS of code completely devoid of comments ??? - -- This is not our general style ??? + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - declare - C, CC : UInt; + New_Capacity := 2 * New_Capacity; + end loop; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - C := 2 * C; - end loop; + New_Capacity := Max_Length; + end if; - if C > Max_Length then - C := Max_Length; - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - if C > CC then - C := CC; - end if; + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - Int'(1)); + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + Dst := new Elements_Type (Dst_Last); - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. - Index : constant Index_Type := Index_Type (Index_As_Int); + declare + Src : Elements_Access := Container.Elements; - Src : Elements_Access := Container.Elements; + begin + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); + -- We have copied the elements from to the old, source array to + -- the new, destination array, so we can now deallocate the old + -- array. Container.Elements := Dst; - Container.Last := New_Last; Free (Src); - for J in Before .. Index - 1 loop - Dst.EA (J) := new Element_Type'(New_Item); + -- Now we append the new items. + + for Idx in Before .. New_Last loop + -- In order to preserve container invariants, we always + -- attempt the element allocation first, before setting the + -- Last index value, in case the allocation fails (either + -- because there is no storage available, or because element + -- initialization fails). + + Dst.EA (Idx) := new Element_Type'(New_Item); + + -- The allocation of the element succeeded, so it is now safe + -- to update the Last index, restoring container invariants. + + Container.Last := Idx; end loop; - end; - else - declare - Src : Elements_Access := Container.Elements; + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. - begin - Dst.EA (Index_Type'First .. Container.Last) := - Src.EA (Index_Type'First .. Container.Last); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); + + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); + + -- We have copied the elements from to the old, source array to + -- the new, destination array, so we can now deallocate the old + -- array. Container.Elements := Dst; + Container.Last := New_Last; Free (Src); - for J in Before .. New_Last loop - Dst.EA (J) := new Element_Type'(New_Item); - Container.Last := J; + -- The new array has a range in the middle containing null access + -- values. We now fill in that partion of the array with the new + -- items. + + for Idx in Before .. Index - 1 loop + -- Note that container invariants have already been satisfied + -- (in particular, the Last index value of the vector has + -- already been updated), so if this allocation fails we simply + -- let it propagate. + + Dst.EA (Idx) := new Element_Type'(New_Item); end loop; - end; - end if; + end if; + end; end Insert; procedure Insert @@ -1295,67 +1705,40 @@ package body Ada.Containers.Indefinite_Vectors is New_Item : Vector) is N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; begin - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; + Insert_Space (Container, Before, Count => N); if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + return; end if; - Insert_Space (Container, Before, Count => N); - - declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; - - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); - - Dst : Elements_Array renames - Container.Elements.EA (Before .. Dst_Last); - - Dst_Index : Index_Type'Base := Before - 1; - - begin - if Container'Address /= New_Item'Address then - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. New_Item.Last; - - Src : Elements_Array renames - New_Item.Elements.EA (Src_Index_Subtype); - - begin - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; - - return; - end if; + if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. declare subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Before - 1; + Index_Type'First .. New_Item.Last; Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + New_Item.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; begin + Dst_Index := Before - 1; for Src_Index in Src'Range loop Dst_Index := Dst_Index + 1; @@ -1365,26 +1748,104 @@ package body Ada.Containers.Indefinite_Vectors is end loop; end; - if Dst_Last = Container.Last then + return; + end if; + + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The first source slice is + -- [Index_Type'First, Before), and the second source slice is + -- [J, Container.Last], where index value J is the first index of the + -- second slice. (J gets computed below, but only after we have + -- determined that the second source slice is non-empty.) The + -- destination slice is always the range [Before, J). We perform the + -- copy in two steps, using each of the two slices of the source items. + + declare + L : constant Index_Type'Base := Before - 1; + + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + -- We first copy the source items that precede the space we + -- inserted. (If Before equals Index_Type'First, then this first + -- source slice will be empty, which is harmless.) + + Dst_Index := Before - 1; + for Src_Index in Src'Range loop + Dst_Index := Dst_Index + 1; + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + + if Src'Length = N then + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J, which will overflow if J is greater than + -- Index_Type'Base'Last. + return; end if; + end; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Dst_Last + 1 .. Container.Last; + -- Index value J is the first index of the second source slice. (It is + -- also 1 greater than the last index of the destination slice.) Note + -- that we want to avoid computing J, if J is greater than + -- Index_Type'Base'Last, in order to avoid overflow. We prevent that by + -- returning early above, immediately after copying the first slice of + -- the source, and determining that this second slice of the source is + -- empty. - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + J := Before + Index_Type'Base (N); - begin - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; + else + J := Index_Type'Base (Count_Type'Base (Before) + N); + end if; - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; + declare + subtype Src_Index_Subtype is Index_Type'Base range + J .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + -- We next copy the source items that follow the space we + -- inserted. Index value Dst_Index is the first index of that portion + -- of the destination that receives this slice of the source. (For + -- the reasons given above, this slice is guaranteed to be + -- non-empty.) + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Index := J - Index_Type'Base (Src'Length); + + else + Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); + end if; + + for Src_Index in Src'Range loop + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + + Dst_Index := Dst_Index + 1; + end loop; end; end Insert; @@ -1561,22 +2022,42 @@ package body Ada.Containers.Indefinite_Vectors is Before : Extended_Index; Count : Count_Type := 1) is - N : constant Int := Int (Count); + Old_Length : constant Count_Type := Container.Length; - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1584,60 +2065,178 @@ package body Ada.Containers.Indefinite_Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + 1); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately + -- allocated. We have no elements here (because we're inserting + -- "space"), so all we need to do is allocate the backbone. + Container.Elements := new Elements_Type (New_Last); Container.Last := New_Last; + return; end if; - if New_Last <= Container.Elements.Last then + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + declare E : Elements_Array renames Container.Elements.EA; begin if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The new space is being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index - 1) := (others => null); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index - 1) := (others => null); end if; end; @@ -1645,68 +2244,80 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + New_Capacity := 2 * New_Capacity; + end loop; - C := 2 * C; - end loop; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - if C > Max_Length then - C := Max_Length; - end if; + New_Capacity := Max_Length; + end if; - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if C > CC then - C := CC; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. declare Src : Elements_Access := Container.Elements; begin + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); + if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); - - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; - else - Dst.EA (Index_Type'First .. Container.Last) := - Src.EA (Index_Type'First .. Container.Last); + Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); end if; + -- We have copied the elements from to the old, source array to the + -- new, destination array, so we can now restore invariants, and + -- deallocate the old array. + Container.Elements := Dst; Container.Last := New_Last; Free (Src); @@ -1808,7 +2419,7 @@ package body Ada.Containers.Indefinite_Vectors is return (Container'Unchecked_Access, Container.Last); end Last; - ------------------ + ----------------- -- Last_Element -- ------------------ @@ -1845,12 +2456,33 @@ package body Ada.Containers.Indefinite_Vectors is ------------ function Length (Container : Vector) return Count_Type is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Count_Type (N); + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; end Length; ---------- @@ -2131,17 +2763,53 @@ package body Ada.Containers.Indefinite_Vectors is is N : constant Count_Type := Length (Container); + Index : Count_Type'Base; + Last : Index_Type'Base; + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + if Capacity = 0 then + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + if N = 0 then + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + declare X : Elements_Access := Container.Elements; begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception + -- (although that's unlikely, since this is simply an array of + -- access values, all of which are null). + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + Free (X); end; elsif N < Container.Elements.EA'Length then + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -2157,7 +2825,19 @@ package body Ada.Containers.Indefinite_Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so we can + -- deallocate the old array. + Free (X); end; end if; @@ -2165,29 +2845,102 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; - if Container.Elements = null then - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with index values greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + raise Constraint_Error with "Capacity is out of range"; + end if; - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + Last := No_Index + Index_Type'Base (Capacity); - begin - Container.Elements := new Elements_Type (Last); - end; - end; + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + + if Container.Elements = null then + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate storage having the given + -- capacity. + + Container.Elements := new Elements_Type (Last); return; end if; if Capacity <= N then + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + if N < Container.Elements.EA'Length then + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so + -- there's storage available to trim. In this case, we allocate a + -- new internal array having a length that exactly matches the + -- number of items in the container. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -2203,7 +2956,19 @@ package body Ada.Containers.Indefinite_Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to deallocate the old array. + Free (X); end; end if; @@ -2211,47 +2976,57 @@ package body Ada.Containers.Indefinite_Vectors is return; end if; + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + if Capacity = Container.Elements.EA'Length then + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + return; end if; + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + -- We now allocate a new internal array, having a length different from + -- its current value. - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + declare + X : Elements_Access := Container.Elements; - declare - Last : constant Index_Type := Index_Type (Last_As_Int); - X : Elements_Access := Container.Elements; + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + begin + -- We now allocate a new internal array, having a length different + -- from its current value. - begin - Container.Elements := new Elements_Type (Last); + Container.Elements := new Elements_Type (Last); - declare - Src : Elements_Array renames - X.EA (Index_Subtype); + -- We have successfully allocated the new internal array, so now we + -- move the existing elements from the existing the old internal + -- array onto the new one. Note that we're just copying access + -- values, to this should not raise any exceptions. - Tgt : Elements_Array renames - Container.Elements.EA (Index_Subtype); + Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype); - begin - Tgt := Src; - end; + -- We have moved the elements from the old interal array, so now we + -- can deallocate it. - Free (X); - end; + Free (X); end; end Reserve_Capacity; @@ -2388,45 +3163,25 @@ package body Ada.Containers.Indefinite_Vectors is (Container : in out Vector; Length : Count_Type) is - N : constant Count_Type := Indefinite_Vectors.Length (Container); + Count : constant Count_Type'Base := Container.Length - Length; begin - if Length = N then - return; - end if; + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less than the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - - if Length < N then - for Index in 1 .. N - Length loop - declare - J : constant Index_Type := Container.Last; - X : Element_Access := Container.Elements.EA (J); - - begin - Container.Elements.EA (J) := null; - Container.Last := J - 1; - Free (X); - end; - end loop; + if Count >= 0 then + Container.Delete_Last (Count); - return; - end if; + elsif Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); + else + Container.Insert_Space (Container.Last + 1, -Count); end if; - - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; - - begin - Container.Last := Index_Type (Last_As_Int); - end; end Set_Length; ---------- @@ -2529,8 +3284,8 @@ package body Ada.Containers.Indefinite_Vectors is --------------- function To_Vector (Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2539,45 +3294,75 @@ package body Ada.Containers.Indefinite_Vectors is end if; -- We create a vector object with a capacity that matches the specified - -- Length. We do not allow the vector capacity (the length of the + -- Length, but we do not allow the vector capacity (the length of the -- internal array) to exceed the number of values in Index_Type'Range -- (otherwise, there would be no way to refer to those components via an - -- index), so we must check whether the specified Length would create a - -- Last index value greater than Index_Type'Last. This calculation - -- requires care, because overflow can occur when Index_Type'First is - -- near the end of the range of Int. - - if Index_Type'First <= 0 then - -- Compute the potential Last index value in the normal way, using - -- Int as the type in which to perform intermediate calculations. Int - -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow - -- can occur. - Index := Int (Index_Type'First - 1) + Int (Length); - - if Index > Int (Index_Type'Last) then + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + else - -- If Index_Type'First is within Length of Int'Last, then overflow - -- would occur if we simply computed Last directly. So instead of - -- computing Last, and then determining whether its value is greater - -- than Index_Type'Last, we work backwards by computing the potential - -- First index value, and then checking whether that value is less - -- than Index_Type'First. - Index := Int (Index_Type'Last) - Int (Length) + 1; - - if Index < Int (Index_Type'First) then + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; - -- We have determined that Length would not create a Last index value - -- outside of the range of Index_Type, so we can now safely compute - -- its value. - Index := Int (Index_Type'First - 1) + Int (Length); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); end if; - Last := Index_Type (Index); Elements := new Elements_Type (Last); return Vector'(Controlled with Elements, Last, 0, 0); @@ -2587,8 +3372,8 @@ package body Ada.Containers.Indefinite_Vectors is (New_Item : Element_Type; Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2597,51 +3382,81 @@ package body Ada.Containers.Indefinite_Vectors is end if; -- We create a vector object with a capacity that matches the specified - -- Length. We do not allow the vector capacity (the length of the + -- Length, but we do not allow the vector capacity (the length of the -- internal array) to exceed the number of values in Index_Type'Range -- (otherwise, there would be no way to refer to those components via an - -- index), so we must check whether the specified Length would create a - -- Last index value greater than Index_Type'Last. This calculation - -- requires care, because overflow can occur when Index_Type'First is - -- near the end of the range of Int. - - if Index_Type'First <= 0 then - -- Compute the potential Last index value in the normal way, using - -- Int as the type in which to perform intermediate calculations. Int - -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow - -- can occur. - Index := Int (Index_Type'First - 1) + Int (Length); - - if Index > Int (Index_Type'Last) then + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then raise Constraint_Error with "Length is out of range"; end if; + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + else - -- If Index_Type'First is within Length of Int'Last, then overflow - -- would occur if we simply computed Last directly. So instead of - -- computing Last, and then determining whether its value is greater - -- than Index_Type'Last, we work backwards by computing the potential - -- First index value, and then checking whether that value is less - -- than Index_Type'First. - Index := Int (Index_Type'Last) - Int (Length) + 1; - - if Index < Int (Index_Type'First) then + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; - -- We have determined that Length would not create a Last index value - -- outside of the range of Index_Type, so we can now safely compute - -- its value. - Index := Int (Index_Type'First - 1) + Int (Length); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); end if; - Last := Index_Type (Index); Elements := new Elements_Type (Last); -- We use Last as the index of the loop used to populate the internal -- array with items. In general, we prefer to initialize the loop index -- immediately prior to entering the loop. However, Last is also used in - -- the exception handler (it reclaims elements that have been allocated, + -- the exception handler (to reclaim elements that have been allocated, -- before propagating the exception), and the initialization of Last -- after entering the block containing the handler confuses some static -- analysis tools, with respect to whether Last has been properly diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads index 8d66e1542b9..55d0a500525 100644 --- a/gcc/ada/a-comlin.ads +++ b/gcc/ada/a-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -73,6 +73,9 @@ package Ada.Command_Line is -- Note on Interface Requirements -- ------------------------------------ + -- Services in this package are not supported during the elaboration of an + -- auto-initialized Stand-Alone Library. + -- If the main program is in Ada, this package works as specified without -- any other work than the normal steps of WITH'ing the package and then -- calling the desired routines. diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 8d146b07dec..501128b9d89 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, 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- -- @@ -34,9 +34,6 @@ with System; use type System.Address; package body Ada.Containers.Vectors is - type Int is range System.Min_Int .. System.Max_Int; - type UInt is mod System.Max_Binary_Modulus; - procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); @@ -45,10 +42,22 @@ package body Ada.Containers.Vectors is --------- function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + N : Count_Type'Base; -- length of result + J : Count_Type'Base; -- for computing intermediate index values + Last : Index_Type'Base; -- Last index of result begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the vector parameters. We could decide to make it larger, but we + -- have no basis for knowing how much larger, so we just allocate the + -- minimum amount of storage. + + -- Here we handle the easy cases first, when one of the vector + -- parameters is empty. (We say "easy" because there's nothing to + -- compute, that can potentially overflow.) + if LN = 0 then if RN = 0 then return Empty_Vector; @@ -80,82 +89,116 @@ package body Ada.Containers.Vectors is end if; - declare - N : constant Int'Base := Int (LN) + Int (RN); - J : Int'Base; + -- Neither of the vector parameters is empty, so must compute the length + -- of the result vector and its last index. (This is the harder case, + -- because our computations must avoid overflow.) - begin - -- There are two constraints we need to satisfy. The first constraint - -- is that a container cannot have more than Count_Type'Last - -- elements, so we must check the sum of the combined lengths. (It - -- would be rare for vectors to have such a large number of elements, - -- so we would normally expect this first check to succeed.) The - -- second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. - - if N > Count_Type'Pos (Count_Type'Last) then + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the combined lengths. Note that we cannot + -- simply add the lengths, because of the possibilty of overflow. + + if LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + N := LN + RN; + + -- The second constraint is that the new Last index value cannot + -- exceed Index_Type'Last. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (N) < No_Index then raise Constraint_Error with "new length is out of range"; end if; - -- We now check whether the new length would create a Last index - -- value greater than Index_Type'Last. This calculation requires - -- care, because overflow can occur when Index_Type'First is near the - -- end of the range of Int. + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - if Index_Type'First <= 0 then + Last := No_Index + Index_Type'Base (N); - -- Compute the potential Last index value in the normal way, using - -- Int as the type in which to perform intermediate - -- calculations. Int is a 64-bit type, and Count_Type is a 32-bit - -- type, so no overflow can occur. + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: - J := Int (Index_Type'First - 1) + N; + if Last > Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; - if J > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of length. - else - -- If Index_Type'First is within N of Int'Last, then overflow - -- would occur if we simply computed Last directly. So instead of - -- computing Last, and then determining whether its value is - -- greater than Index_Type'Last (as we do above), we work - -- backwards by computing the potential First index value, and - -- then checking whether that value is less than Index_Type'First. + J := Count_Type'Base (No_Index) + N; -- Last + + if J > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; - J := Int (Index_Type'Last) - N + 1; + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: - if J < Int (Index_Type'First) then - raise Constraint_Error with "new length is out of range"; - end if; + Last := Index_Type'Base (J); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. - -- We have determined that Length would not create a Last index - -- value outside of the range of Index_Type, so we can now safely - -- compute its value. + J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - J := Int (Index_Type'First - 1) + N; + if J < Count_Type'Base (No_Index) then + raise Constraint_Error with "new length is out of range"; end if; - declare - Last : constant Index_Type := Index_Type (J); + -- We have determined that the result length would not create a Last + -- index value outside of the range of Index_Type, so we can now + -- safely compute its value. - LE : Elements_Array renames - Left.Elements.EA (Index_Type'First .. Left.Last); + Last := Index_Type'Base (Count_Type'Base (No_Index) + N); + end if; - RE : Elements_Array renames - Right.Elements.EA (Index_Type'First .. Right.Last); + declare + LE : Elements_Array renames + Left.Elements.EA (Index_Type'First .. Left.Last); - Elements : constant Elements_Access := - new Elements_Type'(Last, LE & RE); + RE : Elements_Array renames + Right.Elements.EA (Index_Type'First .. Right.Last); - begin - return (Controlled with Elements, Last, 0, 0); - end; + Elements : constant Elements_Access := + new Elements_Type'(Last, LE & RE); + + begin + return (Controlled with Elements, Last, 0, 0); end; end "&"; function "&" (Left : Vector; Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Left) + -- is empty. + if Left.Is_Empty then declare Elements : constant Elements_Access := @@ -168,8 +211,10 @@ package body Ada.Containers.Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Left.Length = Count_Type'Last then @@ -198,6 +243,14 @@ package body Ada.Containers.Vectors is function "&" (Left : Element_Type; Right : Vector) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- Here we handle the easy case first, when the vector parameter (Right) + -- is empty. + if Right.Is_Empty then declare Elements : constant Elements_Access := @@ -210,8 +263,10 @@ package body Ada.Containers.Vectors is end; end if; - -- We must satisfy two constraints: the new length cannot exceed - -- Count_Type'Last, and the new Last index cannot exceed + -- The vector parameter is not empty, so we must compute the length of + -- the result vector and its last index, but in such a way that overflow + -- is avoided. We must satisfy two constraints: the new length cannot + -- exceed Count_Type'Last, and the new Last index cannot exceed -- Index_Type'Last. if Right.Length = Count_Type'Last then @@ -240,6 +295,17 @@ package body Ada.Containers.Vectors is function "&" (Left, Right : Element_Type) return Vector is begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last (here, we + -- know that that condition is satisfied), and the new Last index cannot + -- exceed Index_Type'Last. + if Index_Type'First >= Index_Type'Last then raise Constraint_Error with "new length is out of range"; end if; @@ -401,56 +467,117 @@ package body Ada.Containers.Vectors is Index : Extended_Index; Count : Count_Type := 1) is - begin + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; - if Index > Container.Last then - if Index > Container.Last + 1 then + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then raise Constraint_Error with "Index is out of range (too large)"; end if; return; end if; + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + if Count = 0 then return; end if; + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; - declare - I_As_Int : constant Int := Int (Index); - Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) - Count1 : constant Int'Base := Count_Type'Pos (Count); - Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; - N : constant Int'Base := Int'Min (Count1, Count2); + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - J_As_Int : constant Int'Base := I_As_Int + N; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; - begin - if J_As_Int > Old_Last_As_Int then - Container.Last := Index - 1; + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. - else - declare - J : constant Index_Type := Index_Type (J_As_Int); - EA : Elements_Array renames Container.Elements.EA; + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; - New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; - New_Last : constant Index_Type := - Index_Type (New_Last_As_Int); + -- There are some elements aren't being deleted (the requested count was + -- less than the available count), so we must slide them down to + -- Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. - begin - EA (Index .. New_Last) := EA (J .. Container.Last); - Container.Last := New_Last; - end; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := Old_Last - Index_Type'Base (Count); + J := Index + Index_Type'Base (Count); + + else + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + J := Index_Type'Base (Count_Type'Base (Index) + Count); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so we just slide down to Index the elements + -- that weren't deleted. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; end; end Delete; @@ -507,24 +634,47 @@ package body Ada.Containers.Vectors is (Container : in out Vector; Count : Count_Type := 1) is - Index : Int'Base; - begin + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + if Count = 0 then return; end if; + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + if Count >= Container.Length then Container.Last := No_Index; + elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := Container.Last - Index_Type'Base (Count); + else - Index := Int (Container.Last) - Int (Count); - Container.Last := Index_Type (Index); + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); end if; end Delete_Last; @@ -804,22 +954,42 @@ package body Ada.Containers.Vectors is New_Item : Element_Type; Count : Count_Type := 1) is - N : constant Int := Count_Type'Pos (Count); + Old_Length : constant Count_Type := Container.Length; - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - Dst : Elements_Access; + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -827,67 +997,192 @@ package body Ada.Containers.Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + Int'(1)); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because element initialization fails). + Container.Elements := new Elements_Type' (Last => New_Last, EA => (others => New_Item)); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + Container.Last := New_Last; + return; end if; - if New_Last <= Container.Elements.Last then + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. + + if New_Length <= Container.Elements.EA'Length then + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + declare EA : Elements_Array renames Container.Elements.EA; begin - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. - Index : constant Index_Type := Index_Type (Index_As_Int); + EA (Before .. New_Last) := (others => New_Item); - begin - EA (Index .. New_Last) := EA (Before .. Container.Last); + else + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. - EA (Before .. Index_Type'Pred (Index)) := - (others => New_Item); - end; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - else - EA (Before .. New_Last) := (others => New_Item); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + EA (Index .. New_Last) := EA (Before .. Container.Last); + EA (Before .. Index - 1) := (others => New_Item); end if; end; @@ -895,67 +1190,79 @@ package body Ada.Containers.Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + New_Capacity := 2 * New_Capacity; + end loop; - C := 2 * C; - end loop; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - if C > Max_Length then - C := Max_Length; - end if; + New_Capacity := Max_Length; + end if; - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if C > CC then - C := CC; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. declare - SA : Elements_Array renames Container.Elements.EA; - DA : Elements_Array renames Dst.EA; + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination begin - DA (Index_Type'First .. Index_Type'Pred (Before)) := - SA (Index_Type'First .. Index_Type'Pred (Before)); + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); - if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + if Before > Container.Last then + DA (Before .. New_Last) := (others => New_Item); - Index : constant Index_Type := Index_Type (Index_As_Int); + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. - begin - DA (Before .. Index_Type'Pred (Index)) := (others => New_Item); - DA (Index .. New_Last) := SA (Before .. Container.Last); - end; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - else - DA (Before .. New_Last) := (others => New_Item); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + DA (Before .. Index - 1) := (others => New_Item); + DA (Index .. New_Last) := SA (Before .. Container.Last); end if; exception when others => @@ -963,11 +1270,23 @@ package body Ada.Containers.Vectors is raise; end; + -- We have successfully copied the items onto the new array, so the + -- final thing to do is deallocate the old array. + declare X : Elements_Access := Container.Elements; begin + -- We first isolate the old internal array, removing it from the + -- container and replacing it with the new internal array, before we + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + Container.Elements := Dst; Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + Free (X); end; end Insert; @@ -978,83 +1297,118 @@ package body Ada.Containers.Vectors is New_Item : Vector) is N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; begin - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. + + Insert_Space (Container, Before, Count => N); + + if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; end if; - if Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; + -- We calculate the last index value of the destination slice using the + -- wider of Index_Type'Base and count_Type'Base. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + J := (Before - 1) + Index_Type'Base (N); + + else + J := Index_Type'Base (Count_Type'Base (Before - 1) + N); end if; - if N = 0 then + if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. + + Container.Elements.EA (Before .. J) := + New_Item.Elements.EA (Index_Type'First .. New_Item.Last); + return; end if; - Insert_Space (Container, Before, Count => N); + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The destination is always the + -- range [Before, J], but the source is [Index_Type'First, Before) and + -- (J, Container.Last]. We perform the copy in two steps, using each of + -- the two slices of the source items. declare - Dst_Last_As_Int : constant Int'Base := - Int'Base (Before) + Int'Base (N) - 1; + L : constant Index_Type'Base := Before - 1; - Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; - begin - if Container'Address /= New_Item'Address then - Container.Elements.EA (Before .. Dst_Last) := - New_Item.Elements.EA (Index_Type'First .. New_Item.Last); + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); - return; - end if; - - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Before - 1; + K : Index_Type'Base; - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + begin + -- We first copy the source items that precede the space we + -- inserted. Index value K is the last index of that portion + -- destination that receives this slice of the source. (If Before + -- equals Index_Type'First, then this first source slice will be + -- empty, which is harmless.) - Index_As_Int : constant Int'Base := - Int (Before) + Src'Length - 1; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + K := L + Index_Type'Base (Src'Length); - Index : constant Index_Type'Base := - Index_Type'Base (Index_As_Int); + else + K := Index_Type'Base (Count_Type'Base (L) + Src'Length); + end if; - Dst : Elements_Array renames - Container.Elements.EA (Before .. Index); + Container.Elements.EA (Before .. K) := Src; - begin - Dst := Src; - end; + if Src'Length = N then + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J + 1, which will overflow if J equals + -- Index_Type'Base'Last. - if Dst_Last = Container.Last then return; end if; + end; - declare - subtype Src_Index_Subtype is Index_Type'Base range - Dst_Last + 1 .. Container.Last; + declare + -- Note that we want to avoid computing J + 1 here, in case J equals + -- Index_Type'Base'Last. We prevent that by returning early above, + -- immediately after copying the first slice of the source, and + -- determining that this second slice of the source is empty. - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); + F : constant Index_Type'Base := J + 1; - Index_As_Int : constant Int'Base := - Dst_Last_As_Int - Src'Length + 1; + subtype Src_Index_Subtype is Index_Type'Base range + F .. Container.Last; - Index : constant Index_Type := - Index_Type (Index_As_Int); + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); - Dst : Elements_Array renames - Container.Elements.EA (Index .. Dst_Last); + K : Index_Type'Base; - begin - Dst := Src; - end; + begin + -- We next copy the source items that follow the space we + -- inserted. Index value K is the first index of that portion of the + -- destination that receives this slice of the source. (For the + -- reasons given above, this slice is guaranteed to be non-empty.) + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + K := F - Index_Type'Base (Src'Length); + + else + K := Index_Type'Base (Count_Type'Base (F) - Src'Length); + end if; + + Container.Elements.EA (K .. J) := Src; end; end Insert; @@ -1256,22 +1610,42 @@ package body Ada.Containers.Vectors is Before : Extended_Index; Count : Count_Type := 1) is - N : constant Int := Count_Type'Pos (Count); + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion - First : constant Int := Int (Index_Type'First); - New_Last_As_Int : Int'Base; - New_Last : Index_Type; - New_Length : UInt; - Max_Length : constant UInt := UInt (Count_Type'Last); + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch - Dst : Elements_Access; + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; end if; + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + if Before > Container.Last and then Before > Container.Last + 1 then @@ -1279,58 +1653,184 @@ package body Ada.Containers.Vectors is "Before index is out of range (too large)"; end if; + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + if Count = 0 then return; end if; - declare - Old_Last_As_Int : constant Int := Int (Container.Last); + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibilty of overflow. - begin - if Old_Last_As_Int > Int'Last - N then - raise Constraint_Error with "new length is out of range"; - end if; + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; - New_Last_As_Int := Old_Last_As_Int + N; + -- It is now safe compute the length of the new vector, without fear of + -- overflow. - if New_Last_As_Int > Int (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); end if; - New_Length := UInt (New_Last_As_Int - First + Int'(1)); + elsif Index_Type'First <= 0 then + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. - if New_Length > Max_Length then - raise Constraint_Error with "new length is out of range"; + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); end if; - New_Last := Index_Type (New_Last_As_Int); - end; + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + New_Last := No_Index + Index_Type'Base (New_Length); + + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); end if; if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because default-valued element + -- initialization fails). + Container.Elements := new Elements_Type (New_Last); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + Container.Last := New_Last; + return; end if; + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with elements (vector is busy)"; + end if; + + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. + if New_Last <= Container.Elements.Last then + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, and the existing array has enough + -- unused storage for the new items. + declare EA : Elements_Array renames Container.Elements.EA; + begin if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The space is being inserted before some existing elements, + -- so we must slide the existing elements up to their new + -- home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - EA (Index .. New_Last) := EA (Before .. Container.Last); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + EA (Index .. New_Last) := EA (Before .. Container.Last); end if; end; @@ -1338,63 +1838,75 @@ package body Ada.Containers.Vectors is return; end if; - declare - C, CC : UInt; + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; - begin - C := UInt'Max (1, Container.Elements.EA'Length); -- ??? - while C < New_Length loop - if C > UInt'Last / 2 then - C := UInt'Last; - exit; - end if; + New_Capacity := 2 * New_Capacity; + end loop; - C := 2 * C; - end loop; + if New_Capacity > Max_Length then + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) - if C > Max_Length then - C := Max_Length; - end if; + New_Capacity := Max_Length; + end if; - if Index_Type'First <= 0 - and then Index_Type'Last >= 0 - then - CC := UInt (Index_Type'Last) + UInt (-Index_Type'First) + 1; - else - CC := UInt (Int (Index_Type'Last) - First + 1); - end if; + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. - if C > CC then - C := CC; - end if; + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); - declare - Dst_Last : constant Index_Type := - Index_Type (First + UInt'Pos (C) - 1); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; - begin - Dst := new Elements_Type (Dst_Last); - end; - end; + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. declare - SA : Elements_Array renames Container.Elements.EA; - DA : Elements_Array renames Dst.EA; + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination begin - DA (Index_Type'First .. Index_Type'Pred (Before)) := - SA (Index_Type'First .. Index_Type'Pred (Before)); + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); if Before <= Container.Last then - declare - Index_As_Int : constant Int'Base := - Index_Type'Pos (Before) + N; + -- The space is being inserted before some existing elements, so + -- we must slide the existing elements up to their new home. - Index : constant Index_Type := Index_Type (Index_As_Int); + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Index := Before + Index_Type'Base (Count); - begin - DA (Index .. New_Last) := SA (Before .. Container.Last); - end; + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + DA (Index .. New_Last) := SA (Before .. Container.Last); end if; exception when others => @@ -1402,11 +1914,24 @@ package body Ada.Containers.Vectors is raise; end; + -- We have successfully copied the items onto the new array, so the + -- final thing to do is restore invariants, and deallocate the old + -- array. + declare X : Elements_Access := Container.Elements; begin + -- We first isolate the old internal array, removing it from the + -- container and replacing it with the new internal array, before we + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + Container.Elements := Dst; Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + Free (X); end; end Insert_Space; @@ -1533,12 +2058,33 @@ package body Ada.Containers.Vectors is ------------ function Length (Container : Vector) return Count_Type is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Count_Type (N); + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; end Length; ---------- @@ -1799,17 +2345,51 @@ package body Ada.Containers.Vectors is is N : constant Count_Type := Length (Container); + Index : Count_Type'Base; + Last : Index_Type'Base; + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + if Capacity = 0 then + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + if N = 0 then + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + declare X : Elements_Access := Container.Elements; begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception. + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + Free (X); end; elsif N < Container.Elements.EA'Length then + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -1825,7 +2405,23 @@ package body Ada.Containers.Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + Free (X); end; end if; @@ -1833,29 +2429,102 @@ package body Ada.Containers.Vectors is return; end if; - if Container.Elements = null then - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with an index value greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index then + raise Constraint_Error with "Capacity is out of range"; + end if; - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: - declare - Last : constant Index_Type := Index_Type (Last_As_Int); + Last := No_Index + Index_Type'Base (Capacity); - begin - Container.Elements := new Elements_Type (Last); - end; - end; + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + + if Container.Elements = null then + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate (expand) storage having + -- the given capacity. + Container.Elements := new Elements_Type (Last); return; end if; if Capacity <= N then + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + if N < Container.Elements.EA'Length then + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so + -- there's storage available to trim. In this case, we allocate a + -- new internal array having a length that exactly matches the + -- number of items in the container. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -1871,63 +2540,99 @@ package body Ada.Containers.Vectors is X : Elements_Access := Container.Elements; begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have succesfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + Free (X); end; - end if; return; end if; + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + if Capacity = Container.Elements.EA'Length then + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + return; end if; + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; end if; + -- We now allocate a new internal array, having a length different from + -- its current value. + declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Capacity) - 1; + E : Elements_Access := new Elements_Type (Last); begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; + -- We have successfully allocated the new internal array. We first + -- attempt to copy the existing elements from the old internal array + -- ("src" elements) onto the new internal array ("tgt" elements). declare - Last : constant Index_Type := Index_Type (Last_As_Int); + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Index_Subtype); - E : Elements_Access := new Elements_Type (Last); + Tgt : Elements_Array renames E.EA (Index_Subtype); begin - declare - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; + Tgt := Src; - Src : Elements_Array renames - Container.Elements.EA (Index_Subtype); + exception + when others => + Free (E); + raise; + end; - Tgt : Elements_Array renames E.EA (Index_Subtype); + -- We have successfully copied the existing elements onto the new + -- internal array, so now we can attempt to deallocate the old one. - begin - Tgt := Src; + declare + X : Elements_Access := Container.Elements; + begin + -- First we isolate the old internal array, and replace it in the + -- container with the new internal array. - exception - when others => - Free (E); - raise; - end; + Container.Elements := E; - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := E; - Free (X); - end; + -- Container invariants have been restored, so it is now safe to + -- attempt to deallocate the old internal array. + + Free (X); end; end; end Reserve_Capacity; @@ -2055,26 +2760,25 @@ package body Ada.Containers.Vectors is ---------------- procedure Set_Length (Container : in out Vector; Length : Count_Type) is + Count : constant Count_Type'Base := Container.Length - Length; + begin - if Length = Vectors.Length (Container) then - return; - end if; + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less then the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; + if Count >= 0 then + Container.Delete_Last (Count); - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; + elsif Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; - declare - Last_As_Int : constant Int'Base := - Int (Index_Type'First) + Int (Length) - 1; - begin - Container.Last := Index_Type'Base (Last_As_Int); - end; + else + Container.Insert_Space (Container.Last + 1, -Count); + end if; end Set_Length; ---------- @@ -2167,8 +2871,8 @@ package body Ada.Containers.Vectors is --------------- function To_Vector (Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2181,41 +2885,71 @@ package body Ada.Containers.Vectors is -- internal array) to exceed the number of values in Index_Type'Range -- (otherwise, there would be no way to refer to those components via an -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. This - -- calculation requires care, because overflow can occur when - -- Index_Type'First is near the end of the range of Int. - - if Index_Type'First <= 0 then - -- Compute the potential Last index value in the normal way, using - -- Int as the type in which to perform intermediate calculations. Int - -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow - -- can occur. - Index := Int (Index_Type'First - 1) + Int (Length); - - if Index > Int (Index_Type'Last) then + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then raise Constraint_Error with "Length is out of range"; end if; + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + else - -- If Index_Type'First is within Length of Int'Last, then overflow - -- would occur if we simply computed Last directly. So instead of - -- computing Last, and then determining whether its value is greater - -- than Index_Type'Last, we work backwards by computing the potential - -- First index value, and then checking whether that value is less - -- than Index_Type'First. - Index := Int (Index_Type'Last) - Int (Length) + 1; - - if Index < Int (Index_Type'First) then + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; - -- We have determined that Length would not create a Last index value - -- outside of the range of Index_Type, so we can now safely compute - -- its value. - Index := Int (Index_Type'First - 1) + Int (Length); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); end if; - Last := Index_Type (Index); Elements := new Elements_Type (Last); return Vector'(Controlled with Elements, Last, 0, 0); @@ -2225,8 +2959,8 @@ package body Ada.Containers.Vectors is (New_Item : Element_Type; Length : Count_Type) return Vector is - Index : Int'Base; - Last : Index_Type; + Index : Count_Type'Base; + Last : Index_Type'Base; Elements : Elements_Access; begin @@ -2239,41 +2973,71 @@ package body Ada.Containers.Vectors is -- internal array) to exceed the number of values in Index_Type'Range -- (otherwise, there would be no way to refer to those components via an -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. This - -- calculation requires care, because overflow can occur when - -- Index_Type'First is near the end of the range of Int. - - if Index_Type'First <= 0 then - -- Compute the potential Last index value in the normal way, using - -- Int as the type in which to perform intermediate calculations. Int - -- is a 64-bit type, and Count_Type is a 32-bit type, so no overflow - -- can occur. - Index := Int (Index_Type'First - 1) + Int (Length); - - if Index > Int (Index_Type'Last) then + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Index_Type'Base'Last - Index_Type'Base (Length) < No_Index then raise Constraint_Error with "Length is out of range"; end if; + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last + + if Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + else - -- If Index_Type'First is within Length of Int'Last, then overflow - -- would occur if we simply computed Last directly. So instead of - -- computing Last, and then determining whether its value is greater - -- than Index_Type'Last, we work backwards by computing the potential - -- First index value, and then checking whether that value is less - -- than Index_Type'First. - Index := Int (Index_Type'Last) - Int (Length) + 1; - - if Index < Int (Index_Type'First) then + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Index < Count_Type'Base (No_Index) then raise Constraint_Error with "Length is out of range"; end if; - -- We have determined that Length would not create a Last index value - -- outside of the range of Index_Type, so we can now safely compute - -- its value. - Index := Int (Index_Type'First - 1) + Int (Length); + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); end if; - Last := Index_Type (Index); Elements := new Elements_Type'(Last, EA => (others => New_Item)); return Vector'(Controlled with Elements, Last, 0, 0); diff --git a/gcc/ada/a-excpol-abort.adb b/gcc/ada/a-excpol-abort.adb index daea6fb80da..94acae6a10b 100644 --- a/gcc/ada/a-excpol-abort.adb +++ b/gcc/ada/a-excpol-abort.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,7 @@ -- that activates periodic polling. Then in the body of the polling routine -- we test for asynchronous abort. --- NT, OS/2, HPUX/DCE and SCO currently use this file +-- Windows, HPUX 10 and VMS currently use this file pragma Warnings (Off); -- Allow withing of non-Preelaborated units in Ada 2005 mode where this diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb index 81cc68a718a..7cf48713a6b 100644 --- a/gcc/ada/a-ngcoty.adb +++ b/gcc/ada/a-ngcoty.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,6 +43,12 @@ package body Ada.Numerics.Generic_Complex_Types is --------- function "*" (Left, Right : Complex) return Complex is + + Scale : constant R := R (R'Machine_Radix) ** ((R'Machine_Emax - 1) / 2); + -- In case of overflow, scale the operands by the largest power of the + -- radix (to avoid rounding error), so that the square of the scale does + -- not overflow itself. + X : R; Y : R; @@ -53,14 +59,20 @@ package body Ada.Numerics.Generic_Complex_Types is -- If either component overflows, try to scale (skip in fast math mode) if not Standard'Fast_Math then - if abs (X) > R'Last then - X := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0) - - R'(Left.Im / 2.0) * R'(Right.Im / 2.0)); + + -- Note that the test below is written as a negation. This is to + -- account for the fact that X and Y may be NaNs, because both of + -- their operands could overflow. Given that all operations on NaNs + -- return false, the test can only be written thus. + + if not (abs (X) <= R'Last) then + X := Scale**2 * ((Left.Re / Scale) * (Right.Re / Scale) - + (Left.Im / Scale) * (Right.Im / Scale)); end if; - if abs (Y) > R'Last then - Y := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0) - - R'(Left.Im / 2.0) * R'(Right.Re / 2.0)); + if not (abs (Y) <= R'Last) then + Y := Scale**2 * ((Left.Re / Scale) * (Right.Im / Scale) + + (Left.Im / Scale) * (Right.Re / Scale)); end if; end if; @@ -569,7 +581,8 @@ package body Ada.Numerics.Generic_Complex_Types is -- in order to prevent inaccuracies on machines where not all -- immediate expressions are rounded, such as PowerPC. - if Re2 > R'Last then + -- ??? same weird test, why not Re2 > R'Last ??? + if not (Re2 <= R'Last) then raise Constraint_Error; end if; @@ -582,7 +595,8 @@ package body Ada.Numerics.Generic_Complex_Types is begin Im2 := X.Im ** 2; - if Im2 > R'Last then + -- ??? same weird test + if not (Im2 <= R'Last) then raise Constraint_Error; end if; diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb index 87abcd8f100..ca81ba51895 100644 --- a/gcc/ada/a-nudira.adb +++ b/gcc/ada/a-nudira.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,64 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; - -with Interfaces; use Interfaces; - package body Ada.Numerics.Discrete_Random is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is very awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution is to use the heap and pointers, and, to avoid memory leaks, - -- controlled types. - - -- This is awfully heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - type Pointer is access all State; - - Fits_In_32_Bits : constant Boolean := - Rst'Size < 31 - or else (Rst'Size = 31 - and then Rst'Pos (Rst'First) < 0); - -- This is set True if we do not need more than 32 bits in the result. If - -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit - -- number generated, since if more than 48 bits are required, we split the - -- computation into two separate parts, since the algorithm does not behave - -- above 48 bits. - - -- The way this expression works is that obviously if the size is 31 bits, - -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the - -- range has negative values. It is too conservative in the case that the - -- programmer has set a size greater than the default, e.g. a size of 33 - -- for an integer type with a range of 1..10, but an over-conservative - -- result is OK. The important thing is that the value is only True if - -- we know the result will fit in 32-bits signed. If the value is False - -- when it could be True, the behavior will be correct, just a bit less - -- efficient than it could have been in some unusual cases. - -- - -- One might assume that we could get a more accurate result by testing - -- the lower and upper bounds of the type Rst against the bounds of 32-bit - -- Integer. However, there is no easy way to do that. Why? Because in the - -- relatively rare case where this expresion has to be evaluated at run - -- time rather than compile time (when the bounds are dynamic), we need a - -- type to use for the computation. But the possible range of upper bound - -- values for Rst (remembering the possibility of 64-bit modular types) is - -- from -2**63 to 2**64-1, and no run-time type has a big enough range. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Square_Mod_N (X, N : Int) return Int; - pragma Inline (Square_Mod_N); - -- Computes X**2 mod N avoiding intermediate overflow + package SRN renames System.Random_Numbers; + use SRN; ----------- -- Image -- @@ -94,204 +40,55 @@ package body Ada.Numerics.Discrete_Random is function Image (Of_State : State) return String is begin - return Int'Image (Of_State.X1) & - ',' & - Int'Image (Of_State.X2) & - ',' & - Int'Image (Of_State.Q); + return Image (SRN.State (Of_State)); end Image; ------------ -- Random -- ------------ - function Random (Gen : Generator) return Rst is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - Temp : Int; - TF : Flt; - + function Random (Gen : Generator) return Result_Subtype is + function Random is + new SRN.Random_Discrete (Result_Subtype, Result_Subtype'First); begin - -- Check for flat range here, since we are typically run with checks - -- off, note that in practice, this condition will usually be static - -- so we will not actually generate any code for the normal case. - - if Rst'Last < Rst'First then - raise Constraint_Error; - end if; - - -- Continue with computation if non-flat range - - Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); - Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); - Temp := Genp.X2 - Genp.X1; - - -- Following duplication is not an error, it is a loop unwinding! - - if Temp < 0 then - Temp := Temp + Genp.Q; - end if; - - if Temp < 0 then - Temp := Temp + Genp.Q; - end if; - - TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl; - - -- Pathological, but there do exist cases where the rounding implicit - -- in calculating the scale factor will cause rounding to 'Last + 1. - -- In those cases, returning 'First results in the least bias. - - if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then - return Rst'First; - - elsif not Fits_In_32_Bits then - return Rst'Val (Interfaces.Integer_64 (TF)); - - else - return Rst'Val (Int (TF)); - end if; + return Random (SRN.Generator (Gen)); end Random; ----------- -- Reset -- ----------- - procedure Reset (Gen : Generator; Initiator : Integer) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - X1, X2 : Int; - + procedure Reset (Gen : Generator) is begin - X1 := 2 + Int (Initiator) mod (K1 - 3); - X2 := 2 + Int (Initiator) mod (K2 - 3); - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - -- Eliminate effects of small Initiators - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - FP => K1F, - Scl => Scal); + Reset (SRN.Generator (Gen)); end Reset; - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : Generator) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - Now : constant Calendar.Time := Calendar.Clock; - X1 : Int; - X2 : Int; - + procedure Reset (Gen : Generator; Initiator : Integer) is begin - X1 := Int (Calendar.Year (Now)) * 12 * 31 + - Int (Calendar.Month (Now) * 31) + - Int (Calendar.Day (Now)); - - X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); - - X1 := 2 + X1 mod (K1 - 3); - X2 := 2 + X2 mod (K2 - 3); - - -- Eliminate visible effects of same day starts - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - FP => K1F, - Scl => Scal); - + Reset (SRN.Generator (Gen), Initiator); end Reset; - ----------- - -- Reset -- - ----------- - procedure Reset (Gen : Generator; From_State : State) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; begin - Genp.all := From_State; + Reset (SRN.Generator (Gen), SRN.State (From_State)); end Reset; ---------- -- Save -- ---------- - procedure Save (Gen : Generator; To_State : out State) is + procedure Save (Gen : Generator; To_State : out State) is begin - To_State := Gen.Gen_State; + Save (SRN.Generator (Gen), SRN.State (To_State)); end Save; - ------------------ - -- Square_Mod_N -- - ------------------ - - function Square_Mod_N (X, N : Int) return Int is - begin - return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N))); - end Square_Mod_N; - ----------- -- Value -- ----------- function Value (Coded_State : String) return State is - Last : constant Natural := Coded_State'Last; - Start : Positive := Coded_State'First; - Stop : Positive := Coded_State'First; - Outs : State; - begin - while Stop <= Last and then Coded_State (Stop) /= ',' loop - Stop := Stop + 1; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); - Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); - Outs.P := Outs.Q * 2 + 1; - Outs.FP := Flt (Outs.P); - Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q)); - - -- Now do *some* sanity checks - - if Outs.Q < 31 - or else Outs.X1 not in 2 .. Outs.P - 1 - or else Outs.X2 not in 2 .. Outs.Q - 1 - then - raise Constraint_Error; - end if; - - return Outs; + return State (SRN.State'(Value (Coded_State))); end Value; end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads index 425aa6f9bc9..385f33619f3 100644 --- a/gcc/ada/a-nudira.ads +++ b/gcc/ada/a-nudira.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,39 +33,24 @@ -- -- ------------------------------------------------------------------------------ --- Note: the implementation used in this package was contributed by Robert --- Eachus. It is based on the work of L. Blum, M. Blum, and M. Shub, SIAM --- Journal of Computing, Vol 15. No 2, May 1986. The particular choices for P --- and Q chosen here guarantee a period of 562,085,314,430,582 (about 2**49), --- and the generated sequence has excellent randomness properties. For further --- details, see the paper "Fast Generation of Trustworthy Random Numbers", by --- Robert Eachus, which describes both the algorithm and the efficient --- implementation approach used here. +-- Note: the implementation used in this package is a version of the +-- Mersenne Twister. See s-rannum.adb for details and references. -with Interfaces; +with System.Random_Numbers; generic type Result_Subtype is (<>); package Ada.Numerics.Discrete_Random is - -- The algorithm used here is reliable from a required statistical point of - -- view only up to 48 bits. We try to behave reasonably in the case of - -- larger types, but we can't guarantee the required properties. So - -- generate a warning for these (slightly) dubious cases. - - pragma Compile_Time_Warning - (Result_Subtype'Size > 48, - "statistical properties not guaranteed for size > 48"); - -- Basic facilities type Generator is limited private; function Random (Gen : Generator) return Result_Subtype; - procedure Reset (Gen : Generator); procedure Reset (Gen : Generator; Initiator : Integer); + procedure Reset (Gen : Generator); -- Advanced facilities @@ -74,41 +59,15 @@ package Ada.Numerics.Discrete_Random is procedure Save (Gen : Generator; To_State : out State); procedure Reset (Gen : Generator; From_State : State); - Max_Image_Width : constant := 80; + Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; function Image (Of_State : State) return String; function Value (Coded_State : String) return State; private - subtype Int is Interfaces.Integer_32; - subtype Rst is Result_Subtype; - - -- We prefer to use 14 digits for Flt, but some targets are more limited - - type Flt is digits Positive'Min (14, Long_Long_Float'Digits); - - RstF : constant Flt := Flt (Rst'Pos (Rst'First)); - RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); - - Offs : constant Flt := RstF - 0.5; - - K1 : constant := 94_833_359; - K1F : constant := 94_833_359.0; - K2 : constant := 47_416_679; - K2F : constant := 47_416_679.0; - Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F); - type State is record - X1 : Int := Int (2999 ** 2); - X2 : Int := Int (1439 ** 2); - P : Int := K1; - Q : Int := K2; - FP : Flt := K1F; - Scl : Flt := Scal; - end record; + type Generator is new System.Random_Numbers.Generator; - type Generator is limited record - Gen_State : State; - end record; + type State is new System.Random_Numbers.State; end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb index 7e6323b8e8d..2c6fbc47f6d 100644 --- a/gcc/ada/a-nuflra.adb +++ b/gcc/ada/a-nuflra.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,97 +29,10 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; - package body Ada.Numerics.Float_Random is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is very awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution is to use the heap and pointers, and, to avoid memory leaks, - -- controlled types. - - -- This is awfully heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - type Pointer is access all State; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int); - - function Euclid (P, Q : Int) return Int; - - function Square_Mod_N (X, N : Int) return Int; - - ------------ - -- Euclid -- - ------------ - - procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is - - XT : Int := 1; - YT : Int := 0; - - procedure Recur - (P, Q : Int; -- a (i-1), a (i) - X, Y : Int; -- x (i), y (i) - XP, YP : in out Int; -- x (i-1), y (i-1) - GCD : out Int); - - procedure Recur - (P, Q : Int; - X, Y : Int; - XP, YP : in out Int; - GCD : out Int) - is - Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _| - XT : Int := X; -- x (i) - YT : Int := Y; -- y (i) - - begin - if P rem Q = 0 then -- while does not divide - GCD := Q; - XP := X; - YP := Y; - else - Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo); - - -- a (i) <== a (i) - -- a (i+1) <-- a (i-1) - q*a (i) - -- x (i+1) <-- x (i-1) - q*x (i) - -- y (i+1) <-- y (i-1) - q*y (i) - -- x (i) <== x (i) - -- y (i) <== y (i) - - XP := XT; - YP := YT; - GCD := Quo; - end if; - end Recur; - - -- Start of processing for Euclid - - begin - Recur (P, Q, 0, 1, XT, YT, GCD); - X := XT; - Y := YT; - end Euclid; - - function Euclid (P, Q : Int) return Int is - X, Y, GCD : Int; - pragma Unreferenced (Y, GCD); - begin - Euclid (P, Q, X, Y, GCD); - return X; - end Euclid; + package SRN renames System.Random_Numbers; + use SRN; ----------- -- Image -- @@ -127,185 +40,63 @@ package body Ada.Numerics.Float_Random is function Image (Of_State : State) return String is begin - return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2) - & ',' & - Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q); + return Image (SRN.State (Of_State)); end Image; ------------ -- Random -- ------------ - function Random (Gen : Generator) return Uniformly_Distributed is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - + function Random (Gen : Generator) return Uniformly_Distributed is begin - Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); - Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); - return - Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X) - mod Genp.Q) * Flt (Genp.P) - + Flt (Genp.X1)) * Genp.Scl); + return Random (SRN.Generator (Gen)); end Random; ----------- -- Reset -- ----------- - -- Version that works from given initiator value - - procedure Reset (Gen : Generator; Initiator : Integer) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - X1, X2 : Int; + -- Version that works from calendar + procedure Reset (Gen : Generator) is begin - X1 := 2 + Int (Initiator) mod (K1 - 3); - X2 := 2 + Int (Initiator) mod (K2 - 3); - - -- Eliminate effects of small initiators - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - X => 1, - Scl => Scal); + Reset (SRN.Generator (Gen)); end Reset; - -- Version that works from specific saved state - - procedure Reset (Gen : Generator; From_State : State) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + -- Version that works from given initiator value + procedure Reset (Gen : Generator; Initiator : Integer) is begin - Genp.all := From_State; + Reset (SRN.Generator (Gen), Initiator); end Reset; - -- Version that works from calendar - - procedure Reset (Gen : Generator) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - Now : constant Calendar.Time := Calendar.Clock; - X1, X2 : Int; + -- Version that works from specific saved state + procedure Reset (Gen : Generator; From_State : State) is begin - X1 := Int (Calendar.Year (Now)) * 12 * 31 + - Int (Calendar.Month (Now)) * 31 + - Int (Calendar.Day (Now)); - - X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); - - X1 := 2 + X1 mod (K1 - 3); - X2 := 2 + X2 mod (K2 - 3); - - -- Eliminate visible effects of same day starts - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - X => 1, - Scl => Scal); - + Reset (SRN.Generator (Gen), From_State); end Reset; ---------- -- Save -- ---------- - procedure Save (Gen : Generator; To_State : out State) is + procedure Save (Gen : Generator; To_State : out State) is begin - To_State := Gen.Gen_State; + Save (SRN.Generator (Gen), To_State); end Save; - ------------------ - -- Square_Mod_N -- - ------------------ - - function Square_Mod_N (X, N : Int) return Int is - Temp : constant Flt := Flt (X) * Flt (X); - Div : Int; - - begin - Div := Int (Temp / Flt (N)); - Div := Int (Temp - Flt (Div) * Flt (N)); - - if Div < 0 then - return Div + N; - else - return Div; - end if; - end Square_Mod_N; - ----------- -- Value -- ----------- function Value (Coded_State : String) return State is - Last : constant Natural := Coded_State'Last; - Start : Positive := Coded_State'First; - Stop : Positive := Coded_State'First; - Outs : State; - + G : SRN.Generator; + S : SRN.State; begin - while Stop <= Last and then Coded_State (Stop) /= ',' loop - Stop := Stop + 1; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.P := Int'Value (Coded_State (Start .. Stop - 1)); - Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); - Outs.X := Euclid (Outs.P, Outs.Q); - Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q)); - - -- Now do *some* sanity checks - - if Outs.Q < 31 or else Outs.P < 31 - or else Outs.X1 not in 2 .. Outs.P - 1 - or else Outs.X2 not in 2 .. Outs.Q - 1 - then - raise Constraint_Error; - end if; - - return Outs; + Reset (G, Coded_State); + Save (G, S); + return State (S); end Value; + end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-nuflra.ads b/gcc/ada/a-nuflra.ads index e81842e23d8..5a448a7811e 100644 --- a/gcc/ada/a-nuflra.ads +++ b/gcc/ada/a-nuflra.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,17 +33,10 @@ -- -- ------------------------------------------------------------------------------ --- Note: the implementation used in this package was contributed by --- Robert Eachus. It is based on the work of L. Blum, M. Blum, and --- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The --- particular choices for P and Q chosen here guarantee a period of --- 562,085,314,430,582 (about 2**49), and the generated sequence has --- excellent randomness properties. For further details, see the --- paper "Fast Generation of Trustworthy Random Numbers", by Robert --- Eachus, which describes both the algorithm and the efficient --- implementation approach used here. +-- Note: the implementation used in this package is a version of the +-- Mersenne Twister. See s-rannum.adb for details and references. -with Interfaces; +with System.Random_Numbers; package Ada.Numerics.Float_Random is @@ -65,35 +58,15 @@ package Ada.Numerics.Float_Random is procedure Save (Gen : Generator; To_State : out State); procedure Reset (Gen : Generator; From_State : State); - Max_Image_Width : constant := 80; + Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; function Image (Of_State : State) return String; function Value (Coded_State : String) return State; private - type Int is new Interfaces.Integer_32; - - -- We prefer to use 14 digits for Flt, but some targets are more limited - - type Flt is digits Positive'Min (14, Long_Long_Float'Digits); - - K1 : constant := 94_833_359; - K1F : constant := 94_833_359.0; - K2 : constant := 47_416_679; - K2F : constant := 47_416_679.0; - Scal : constant := 1.0 / (K1F * K2F); - - type State is record - X1 : Int := 2999 ** 2; -- Square mod p - X2 : Int := 1439 ** 2; -- Square mod q - P : Int := K1; - Q : Int := K2; - X : Int := 1; - Scl : Flt := Scal; - end record; - - type Generator is limited record - Gen_State : State; - end record; + + type Generator is new System.Random_Numbers.Generator; + + type State is new System.Random_Numbers.State; end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index c3cbec69ddc..026c28941a0 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2009, AdaCore -- +-- Copyright (C) 1995-2010, AdaCore -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,6 +32,8 @@ -- -- ------------------------------------------------------------------------------ +with System.Tasking; + package body Ada.Real_Time is --------- @@ -242,4 +244,10 @@ package body Ada.Real_Time is return Time_Span (D); end To_Time_Span; +begin + -- Ensure that the tasking run time is initialized when using clock and/or + -- delay operations. The initialization routine has the required machinery + -- to prevent multiple calls to Initialize. + + System.Tasking.Initialize; end Ada.Real_Time; diff --git a/gcc/ada/a-retide.adb b/gcc/ada/a-retide.adb index f159ed6fc33..ecc61f6913a 100644 --- a/gcc/ada/a-retide.adb +++ b/gcc/ada/a-retide.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -75,10 +75,4 @@ package body Ada.Real_Time.Delays is return To_Duration (Time_Span (T)); end To_Duration; -begin - -- Ensure that the tasking run time is initialized when using delay - -- operations. The initialization routine has the required machinery to - -- prevent multiple calls to Initialize. - - System.Tasking.Initialize; end Ada.Real_Time.Delays; diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb new file mode 100644 index 00000000000..f4083b59e93 --- /dev/null +++ b/gcc/ada/a-strunb-shared.adb @@ -0,0 +1,2086 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Unbounded is + + use Ada.Strings.Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of the + -- allocated memory segments to use memory effectively by Append/Insert/etc + -- operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left string is empty, return Rigth string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String + is + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + begin + return + ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc + - Static_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate (Max_Length : Natural) return Shared_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_String'Access); + return Empty_Shared_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String) + is + SR : constant Shared_String_Access := Source.Reference; + NR : constant Shared_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_String; + Index : Positive) return Character + is + SR : constant Shared_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_String) is + SR : constant Shared_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_String_Access := Source.Reference; + begin + Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Result is same as source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- existing data and fill remaining positions with Pad characters. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Strings.Direction := Strings.Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL /Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is same as source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + -------------------------- + -- Set_Unbounded_String -- + -------------------------- + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String) + is + TR : constant Shared_String_Access := Target.Reference; + DR : Shared_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + + else + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String + is + SR : constant Shared_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is whole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + --------------- + -- To_String -- + --------------- + + function To_String (Source : Unbounded_String) return String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_String; + + ------------------------- + -- To_Unbounded_String -- + ------------------------- + + function To_Unbounded_String (Source : String) return Unbounded_String is + DR : constant Shared_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + function To_Unbounded_String (Length : Natural) return Unbounded_String is + DR : constant Shared_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + TR : constant Shared_String_Access := Target.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); + + Aux : Shared_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_String must never reach zero + + pragma Assert (Aux /= Empty_Shared_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads new file mode 100644 index 00000000000..b4b7c622759 --- /dev/null +++ b/gcc/ada/a-strunb-shared.ads @@ -0,0 +1,481 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This 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. + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + + -- This package uses several techniques to increase speed: + + -- - Implicit sharing or copy-on-write. An Unbounded_String contains only + -- the reference to the data which is shared between several instances. + -- The shared data is reallocated only when its value is changed and + -- the object mutation can't be used or it is unefficient to use it. + + -- - Object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are met: + -- - shared data object is no longer used by anyone else. + -- - the size is sufficient to store new value. + -- - the gap after reuse is less then a defined threashold. + + -- - Memory preallocation. Most of used memory allocation algorithms + -- allign allocated segments on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_String thread-safe, so each instance can't be + -- accessed by several tasks simulatenously. + +with Ada.Strings.Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Unbounded is + pragma Preelaborate; + + type Unbounded_String is private; + pragma Preelaborable_Initialization (Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String; + + function Length (Source : Unbounded_String) return Natural; + + type String_Access is access all String; + + procedure Free (X : in out String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_String + (Source : String) return Unbounded_String; + + function To_Unbounded_String + (Length : Natural) return Unbounded_String; + + function To_String (Source : Unbounded_String) return String; + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String); + pragma Ada_05 (Set_Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character); + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String; + + function Element + (Source : Unbounded_String; + Index : Positive) return Character; + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character); + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String; + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String); + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String); + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String); + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter + + Last : Natural := 0; + Data : String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are currently insignificant. + end record; + + type Shared_String_Access is access all Shared_String; + + procedure Reference (Item : not null Shared_String_Access); + -- Increment reference counter + + procedure Unreference (Item : not null Shared_String_Access); + -- Decrement reference counter, deallocate Item when counter goes to zero + + function Can_Be_Reused + (Item : Shared_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_String can be reused. There are two criteria when + -- Shared_String can be reused: its reference counter must be one (thus + -- Shared_String is owned exclusively) and its size is sufficient to + -- store string with specified length effectively. + + function Allocate (Max_Length : Natural) return Shared_String_Access; + -- Allocates new Shared_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_String can be sligtly + -- greater. Returns reference to Empty_Shared_String when requested length + -- is zero. + + Empty_Shared_String : aliased Shared_String (0); + + function To_Unbounded (S : String) return Unbounded_String + renames To_Unbounded_String; + -- This renames are here only to be used in the pragma Stream_Convert + + type Unbounded_String is new AF.Controlled with record + Reference : Shared_String_Access := Empty_Shared_String'Access; + end record; + + pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_String); + overriding procedure Adjust (Object : in out Unbounded_String); + overriding procedure Finalize (Object : in out Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String := + (AF.Controlled with + Reference => Empty_Shared_String'Access); + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb.adb b/gcc/ada/a-strunb.adb index 7634e65f6d2..cc5b92bfc43 100644 --- a/gcc/ada/a-strunb.adb +++ b/gcc/ada/a-strunb.adb @@ -914,9 +914,14 @@ package body Ada.Strings.Unbounded is function To_Unbounded_String (Source : String) return Unbounded_String is Result : Unbounded_String; begin - Result.Last := Source'Length; - Result.Reference := new String (1 .. Source'Length); - Result.Reference.all := Source; + -- Do not allocate an empty string: keep the default + + if Source'Length > 0 then + Result.Last := Source'Length; + Result.Reference := new String (1 .. Source'Length); + Result.Reference.all := Source; + end if; + return Result; end To_Unbounded_String; @@ -924,9 +929,15 @@ package body Ada.Strings.Unbounded is (Length : Natural) return Unbounded_String is Result : Unbounded_String; + begin - Result.Last := Length; - Result.Reference := new String (1 .. Length); + -- Do not allocate an empty string: keep the default + + if Length > 0 then + Result.Last := Length; + Result.Reference := new String (1 .. Length); + end if; + return Result; end To_Unbounded_String; diff --git a/gcc/ada/a-stunau-shared.adb b/gcc/ada/a-stunau-shared.adb new file mode 100644 index 00000000000..6ca416243b7 --- /dev/null +++ b/gcc/ada/a-stunau-shared.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Unbounded.Aux is + + ---------------- + -- Get_String -- + ---------------- + + procedure Get_String + (U : Unbounded_String; + S : out Big_String_Access; + L : out Natural) + is + X : aliased Big_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_String; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String (UP : in out Unbounded_String; S : String_Access) is + X : String_Access := S; + + begin + Set_Unbounded_String (UP, S.all); + Free (X); + end Set_String; + +end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/a-stunau.adb b/gcc/ada/a-stunau.adb index e77f71c12b1..c6d2bc43ac3 100644 --- a/gcc/ada/a-stunau.adb +++ b/gcc/ada/a-stunau.adb @@ -37,11 +37,14 @@ package body Ada.Strings.Unbounded.Aux is procedure Get_String (U : Unbounded_String; - S : out String_Access; + S : out Big_String_Access; L : out Natural) is + X : aliased Big_String; + for X'Address use U.Reference.all'Address; + begin - S := U.Reference; + S := X'Unchecked_Access; L := U.Last; end Get_String; @@ -49,17 +52,6 @@ package body Ada.Strings.Unbounded.Aux is -- Set_String -- ---------------- - procedure Set_String (UP : in out Unbounded_String; S : String) is - begin - if S'Length > UP.Last then - Finalize (UP); - UP.Reference := new String (1 .. S'Length); - end if; - - UP.Reference (1 .. S'Length) := S; - UP.Last := S'Length; - end Set_String; - procedure Set_String (UP : in out Unbounded_String; S : String_Access) is begin Finalize (UP); diff --git a/gcc/ada/a-stunau.ads b/gcc/ada/a-stunau.ads index c2d0ec855c0..8cff44f7151 100644 --- a/gcc/ada/a-stunau.ads +++ b/gcc/ada/a-stunau.ads @@ -37,9 +37,12 @@ package Ada.Strings.Unbounded.Aux is pragma Preelaborate; + subtype Big_String is String (1 .. Positive'Last); + type Big_String_Access is access all Big_String; + procedure Get_String (U : Unbounded_String; - S : out String_Access; + S : out Big_String_Access; L : out Natural); pragma Inline (Get_String); -- This procedure returns the internal string pointer used in the @@ -54,18 +57,16 @@ package Ada.Strings.Unbounded.Aux is -- referenced string returned by this call is always one, so the actual -- string data is always accessible as S (1 .. L). - procedure Set_String (UP : in out Unbounded_String; S : String); - pragma Inline (Set_String); - -- This function sets the string contents of the referenced unbounded - -- string to the given string value. It is significantly more efficient - -- than the use of To_Unbounded_String with an assignment, since it - -- avoids the necessity of messing with finalization chains. The lower - -- bound of the string S is not required to be one. + procedure Set_String (UP : out Unbounded_String; S : String) + renames Set_Unbounded_String; + -- This function is simply a renaming of the new Ada 2005 function as shown + -- above. It is provided for historical reasons, but should be removed at + -- this stage??? procedure Set_String (UP : in out Unbounded_String; S : String_Access); pragma Inline (Set_String); - -- This version of Set_String takes a string access value, rather than a - -- string. The lower bound of the string value is required to be one, and - -- this requirement is not checked. + -- This version of Set_Unbounded_String takes a string access value, rather + -- than a string. The lower bound of the string value is required to be + -- one, and this requirement is not checked. end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/a-stuten.adb b/gcc/ada/a-stuten.adb new file mode 100644 index 00000000000..fc669b56ee4 --- /dev/null +++ b/gcc/ada/a-stuten.adb @@ -0,0 +1,209 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U T F _ E N C O D I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding is + use Interfaces; + + -------------- + -- Encoding -- + -------------- + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme + is + begin + if Item'Length >= 2 then + if Item (Item'First .. Item'First + 1) = BOM_16BE then + return UTF_16BE; + + elsif Item (Item'First .. Item'First + 1) = BOM_16LE then + return UTF_16LE; + + elsif Item'Length >= 3 + and then Item (Item'First .. Item'First + 2) = BOM_8 + then + return UTF_8; + end if; + end if; + + return Default; + end Encoding; + + ----------------- + -- From_UTF_16 -- + ----------------- + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String + is + BSpace : constant Natural := 2 * Boolean'Pos (Output_BOM); + Result : UTF_String (1 .. 2 * Item'Length + BSpace); + Len : Natural; + C : Unsigned_16; + Iptr : Natural; + + begin + if Output_BOM then + Result (1 .. 2) := + (if Output_Scheme = UTF_16BE then BOM_16BE else BOM_16LE); + Len := 2; + else + Len := 0; + end if; + + -- Skip input BOM + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- UTF-16BE case + + if Output_Scheme = UTF_16BE then + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (Shift_Right (C, 8)); + Result (Len + 2) := Character'Val (C and 16#00_FF#); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + + -- UTF-16LE case + + else + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (C and 16#00_FF#); + Result (Len + 2) := Character'Val (Shift_Right (C, 8)); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + end if; + + return Result (1 .. Len); + end From_UTF_16; + + -------------------------- + -- Raise_Encoding_Error -- + -------------------------- + + procedure Raise_Encoding_Error (Index : Natural) is + Val : constant String := Index'Img; + begin + raise Encoding_Error with + "bad input at Item (" & Val (Val'First + 1 .. Val'Last) & ')'; + end Raise_Encoding_Error; + + --------------- + -- To_UTF_16 -- + --------------- + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length / 2 + 1); + Len : Natural; + Iptr : Natural; + + begin + if Item'Length mod 2 /= 0 then + raise Encoding_Error with "UTF-16BE/LE string has odd length"; + end if; + + -- Deal with input BOM, skip if OK, error if bad BOM + + Iptr := Item'First; + + if Item'Length >= 2 then + if Item (Iptr .. Iptr + 1) = BOM_16BE then + if Input_Scheme = UTF_16BE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item (Iptr .. Iptr + 1) = BOM_16LE then + if Input_Scheme = UTF_16LE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Raise_Encoding_Error (Iptr); + end if; + end if; + + -- Output BOM if specified + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- UTF-16BE case + + if Input_Scheme = UTF_16BE then + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) * 256 + + Character'Pos (Item (Iptr + 1))); + Iptr := Iptr + 2; + end loop; + + -- UTF-16LE case + + else + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) + + Character'Pos (Item (Iptr + 1)) * 256); + Iptr := Iptr + 2; + end loop; + end if; + + return Result (1 .. Len); + end To_UTF_16; + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stuten.ads b/gcc/ada/a-stuten.ads new file mode 100644 index 00000000000..5299c6f88e2 --- /dev/null +++ b/gcc/ada/a-stuten.ads @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U T F _ E N C O D I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is one of the Ada 2012 package defined in AI05-0137-1. It is a parent +-- package that contains declarations used in the child packages for handling +-- UTF encoded strings. Note: this package is consistent with Ada 95, and may +-- be used in Ada 95 or Ada 2005 mode. + +with Interfaces; +with Unchecked_Conversion; + +package Ada.Strings.UTF_Encoding is + pragma Pure (UTF_Encoding); + + subtype UTF_String is String; + -- Used to represent a string of 8-bit values containing a sequence of + -- values encoded in one of three ways (UTF-8, UTF-16BE, or UTF-16LE). + -- Typically used in connection with a Scheme parameter indicating which + -- of the encodings applies. This is not strictly a String value in the + -- sense defined in the Ada RM, but in practice type String accomodates + -- all possible 256 codes, and can be used to hold any sequence of 8-bit + -- codes. We use String directly rather than create a new type so that + -- all existing facilities for manipulating type String (e.g. the child + -- packages of Ada.Strings) are available for manipulation of UTF_Strings. + + type Encoding_Scheme is (UTF_8, UTF_16BE, UTF_16LE); + -- Used to specify which of three possible encodings apply to a UTF_String + + subtype UTF_8_String is String; + -- Similar to UTF_String but specifically represents a UTF-8 encoded string + + subtype UTF_16_Wide_String is Wide_String; + -- This is similar to UTF_8_String but is used to represent a Wide_String + -- value which is a sequence of 16-bit values encoded using UTF-16. Again + -- this is not strictly a Wide_String in the sense of the Ada RM, but the + -- type Wide_String can be used to represent a sequence of arbitrary 16-bit + -- values, and it is more convenient to use Wide_String than a new type. + + Encoding_Error : exception; + -- This exception is raised in the following situations: + -- a) A UTF encoded string contains an invalid encoding sequence + -- b) A UTF-16BE or UTF-16LE input string has an odd length + -- c) An incorrect character value is present in the Input string + -- d) The result for a Wide_Character output exceeds 16#FFFF# + -- The exception message has the index value where the error occurred. + + -- The BOM (BYTE_ORDER_MARK) values defined here are used at the start of + -- a string to indicate the encoding. The convention in this package is + -- that on input a correct BOM is ignored and an incorrect BOM causes an + -- Encoding_Error exception. On output, the output string may or may not + -- include a BOM depending on the setting of Output_BOM. + + BOM_8 : constant UTF_8_String := + Character'Val (16#EF#) & + Character'Val (16#BB#) & + Character'Val (16#BF#); + + BOM_16BE : constant UTF_String := + Character'Val (16#FE#) & + Character'Val (16#FF#); + + BOM_16LE : constant UTF_String := + Character'Val (16#FF#) & + Character'Val (16#FE#); + + BOM_16 : constant UTF_16_Wide_String := + (1 => Wide_Character'Val (16#FEFF#)); + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme; + -- This function inspects a UTF_String value to determine whether it + -- starts with a BOM for UTF-8, UTF-16BE, or UTF_16LE. If so, the result + -- is the scheme corresponding to the BOM. If no valid BOM is present + -- then the result is the specified Default value. + +private + function To_Unsigned_8 is new + Unchecked_Conversion (Character, Interfaces.Unsigned_8); + + function To_Unsigned_16 is new + Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); + + function To_Unsigned_32 is new + Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); + + subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE; + -- Subtype containing only UTF_16BE and UTF_16LE entries + + -- Utility routines for converting between UTF-16 and UTF-16LE/BE + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String; + -- The input string Item is encoded in UTF-16. The output is encoded using + -- Output_Scheme (which is either UTF-16LE or UTF-16BE). There are no error + -- cases. The output starts with BOM_16BE/LE if Output_BOM is True. + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- The input string Item is encoded using Input_Scheme which is either + -- UTF-16LE or UTF-16BE. The output is the corresponding UTF_16 wide + -- string. Encoding error is raised if the length of the input is odd. + -- The output starts with BOM_16 if Output_BOM is True. + + procedure Raise_Encoding_Error (Index : Natural); + pragma No_Return (Raise_Encoding_Error); + -- Raise Encoding_Error exception for bad encoding in input item. The + -- parameter Index is the index of the location in Item for the error. + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stwiun-shared.adb b/gcc/ada/a-stwiun-shared.adb new file mode 100644 index 00000000000..0f61c7130e6 --- /dev/null +++ b/gcc/ada/a-stwiun-shared.adb @@ -0,0 +1,2104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Unbounded is + + use Ada.Strings.Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left string is empty, return Rigth string. + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string. + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data. + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Right is an empty string, return Left string. + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left is empty string, return Right string. + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if Left = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Coefficient is one, just return string itself. + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal. + end "="; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + return Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_String) is + SR : constant Shared_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + Wide_Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String) + is + TR : constant Shared_Wide_String_Access := Target.Reference; + DR : Shared_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String + is + DR : constant Shared_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String + is + DR : constant Shared_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_String, Shared_Wide_String_Access); + + Aux : Shared_Wide_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_Wide_String must never reach + -- zero. + + pragma Assert (Aux /= Empty_Shared_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stwiun-shared.ads b/gcc/ada/a-stwiun-shared.ads new file mode 100644 index 00000000000..a438258c908 --- /dev/null +++ b/gcc/ada/a-stwiun-shared.ads @@ -0,0 +1,483 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String; + + function Length (Source : Unbounded_Wide_String) return Natural; + + type Wide_String_Access is access all Wide_String; + + procedure Free (X : in out Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String; + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String; + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character); + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character); + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String); + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String); + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String); + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter. + + Last : Natural := 0; + Data : Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indecies are just an extra room. + end record; + + type Shared_Wide_String_Access is access all Shared_Wide_String; + + procedure Reference (Item : not null Shared_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_String can be reused. There are two criteria + -- when Shared_Wide_String can be reused: its reference counter must be one + -- (thus Shared_Wide_String is owned exclusively) and its size is + -- sufficient to store string with specified length effectively. + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access; + -- Allocates new Shared_Wide_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_Wide_String can be sligtly + -- greater. Returns reference to Empty_Shared_Wide_String when requested + -- length is zero. + + Empty_Shared_Wide_String : aliased Shared_Wide_String (0); + + function To_Unbounded (S : Wide_String) return Unbounded_Wide_String + renames To_Unbounded_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; + end record; + + -- The Unbounded_Wide_String uses several techniques to increasy speed of + -- the application: + -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains + -- only the reference to the data which is shared between several + -- instances. The shared data is reallocated only when its value is + -- changed and the object mutation can't be used or it is unefficient to + -- use it; + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less then some threashold. + -- - memory preallocation. Most of used memory allocation algorithms + -- alligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + -- + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_String thread-safe, so each instance + -- can't be accessed by several tasks simulatenously. + + pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_Wide_String); + overriding procedure Adjust (Object : in out Unbounded_Wide_String); + overriding procedure Finalize (Object : in out Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String := + (AF.Controlled with + Reference => Empty_Shared_Wide_String'Access); + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stzunb-shared.adb b/gcc/ada/a-stzunb-shared.adb new file mode 100644 index 00000000000..e20cd98e8a0 --- /dev/null +++ b/gcc/ada/a-stzunb-shared.adb @@ -0,0 +1,2118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Unbounded is + + use Ada.Strings.Wide_Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left string is empty, return Rigth string. + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string. + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data. + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Right is an empty string, return Left string. + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left is empty string, return Right string. + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if Left = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Coefficient is one, just return string itself. + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal. + end "="; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_Wide_String'Size + / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + return Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is + SR : constant Shared_Wide_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + Wide_Wide_Search.Find_Token + (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String) + is + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_Wide_String -- + -------------------- + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DR : constant Shared_Wide_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String + is + DR : constant Shared_Wide_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access); + + Aux : Shared_Wide_Wide_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_Wide_Wide_String must never + -- reach zero. + + pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-stzunb-shared.ads b/gcc/ada/a-stzunb-shared.ads new file mode 100644 index 00000000000..4617f56fdc2 --- /dev/null +++ b/gcc/ada/a-stzunb-shared.ads @@ -0,0 +1,501 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Wide_Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; + + function Length (Source : Unbounded_Wide_Wide_String) return Natural; + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (X : in out Wide_Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character); + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String); + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String); + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String); + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_Wide_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter. + + Last : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indecies are just an extra room. + end record; + + type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String; + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_Wide_String can be reused. There are two + -- criteria when Shared_Wide_Wide_String can be reused: its reference + -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively) + -- and its size is sufficient to store string with specified length + -- effectively. + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access; + -- Allocates new Shared_Wide_Wide_String with at least specified maximum + -- length. Actual maximum length of the allocated Shared_Wide_Wide_String + -- can be sligtly greater. Returns reference to + -- Empty_Shared_Wide_Wide_String when requested length is zero. + + Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0); + + function To_Unbounded + (S : Wide_Wide_String) return Unbounded_Wide_Wide_String + renames To_Unbounded_Wide_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_Wide_String_Access := + Empty_Shared_Wide_Wide_String'Access; + end record; + + -- The Unbounded_Wide_Wide_String uses several techniques to increasy speed + -- of the application: + -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String + -- contains only the reference to the data which is shared between + -- several instances. The shared data is reallocated only when its value + -- is changed and the object mutation can't be used or it is unefficient + -- to use it; + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less then some threashold. + -- - memory preallocation. Most of used memory allocation algorithms + -- alligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + -- + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance + -- can't be accessed by several tasks simulatenously. + + pragma Stream_Convert + (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Adjust + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Finalize + (Object : in out Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := + (AF.Controlled with + Reference => + Empty_Shared_Wide_Wide_String'Access); + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-suenco.adb b/gcc/ada/a-suenco.adb new file mode 100755 index 00000000000..42b7f719a5b --- /dev/null +++ b/gcc/ada/a-suenco.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Conversions is + use Interfaces; + + -- Version convertion from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Nothing to do if identical schemes + + if Input_Scheme = Output_Scheme then + return Item; + + -- For remaining cases, one or other of the operands is UTF-16BE/LE + -- encoded, so go through UTF-16 intermediate. + + else + return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)), + Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Version converting UTF-8/UTF-16BE/LE to UTF-16 + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return To_UTF_16 (Item, Input_Scheme, Output_BOM); + end if; + end Convert; + + -- Version converting UTF-8 to UTF-16 + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length + 1); + -- Maximum length of result, including possible BOM + + Len : Natural := 0; + -- Number of characters stored so far in Result + + Iptr : Natural; + -- Next character to process in Item + + C : Unsigned_8; + -- Input UTF-8 code + + R : Unsigned_16; + -- Output UTF-16 code + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C < 2#10_000000# or else C > 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + else + R := Shift_Left (R, 6) or + Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Convert + + begin + -- Output BOM if required + + if Output_BOM then + Len := Len + 1; + Result (Len) := BOM_16 (1); + end if; + + -- Skip OK BOM + + Iptr := Item'First; + + if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + + -- No BOM present + + else + Iptr := Item'First; + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# + -- UTF-8: 0xxxxxxx + -- UTF-16: 00000000_0xxxxxxx + + if C <= 16#7F# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-8: 110yyyxx 10xxxxxx + -- UTF-16: 00000yyy_xxxxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Codes in the range 16#800# - 16#FFFF# + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + -- UTF-16: yyyyyyyy_xxxxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Make sure that we don't have a result in the forbidden range + -- reserved for UTF-16 surrogate characters. + + if R in 16#D800# .. 16#DF00# then + Raise_Encoding_Error (Iptr - 3); + end if; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx + -- Note: zzzz in the output is input zzzzz - 1 + + elsif C <= 2#11110_111# then + R := Unsigned_16 (C and 2#00000_111#); + Get_Continuation; + + -- R now has zzzzzyyyy + + R := R - 2#0000_1_0000#; + + -- R now has zzzzyyyy (zzzz minus one for the output) + + Get_Continuation; + + -- R now has zzzzyyyyyyyyxx + + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (2#110110_00_0000_0000# or Shift_Right (R, 4)); + + R := R and 2#1111#; + Get_Continuation; + Len := Len + 1; + Result (Len) := + Wide_Character'Val (2#110111_00_0000_0000# or R); + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + + -- Convert from UTF-16 to UTF-8/UTF-16-BE/LE + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return From_UTF_16 (Item, Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Convert from UTF-16 to UTF-8 + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is 3 output codes for each input code + BOM space + + Len : Natural; + -- Number of result codes stored + + Iptr : Natural; + -- Pointer to next input character + + C1, C2 : Unsigned_16; + + zzzzz : Unsigned_16; + yyyyyyyy : Unsigned_16; + xxxxxxxx : Unsigned_16; + -- Components of double length case + + begin + Iptr := Item'First; + + -- Skip BOM at start of input + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Generate output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through input + + while Iptr <= Item'Last loop + C1 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000# - 16#007F# + -- UTF-16: 000000000xxxxxxx + -- UTF-8: 0xxxxxxx + + if C1 <= 16#007F# then + Result (Len + 1) := Character'Val (C1); + Len := Len + 1; + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-16: 00000yyyxxxxxxxx + -- UTF-8: 110yyyxx 10xxxxxx + + elsif C1 <= 16#07FF# then + Result (Len + 1) := + Character'Val + (2#110_000000# or Shift_Right (C1, 6)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 2; + + -- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF# + -- UTF-16: yyyyyyyyxxxxxxxx + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + + elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then + Result (Len + 1) := + Character'Val + (2#1110_0000# or Shift_Right (C1, 12)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#)); + Result (Len + 3) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 3; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- Note: zzzzz in the output is input zzzz + 1 + + elsif C1 <= 2#110110_11_11111111# then + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + else + C2 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + end if; + + if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then + Raise_Encoding_Error (Iptr - 1); + end if; + + zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1; + yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#) + or + (Shift_Right (C2, 8) and 2#000000_11#)); + xxxxxxxx := C2 and 2#11111111#; + + Result (Len + 1) := + Character'Val + (2#11110_000# or (Shift_Right (zzzzz, 2))); + Result (Len + 2) := + Character'Val + (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) + or Shift_Right (yyyyyyyy, 4)); + Result (Len + 3) := + Character'Val + (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) + or Shift_Right (xxxxxxxx, 6)); + Result (Len + 4) := + Character'Val + (2#10_000000# or (xxxxxxxx and 2#00_111111#)); + Len := Len + 4; + + -- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st) + + else + Raise_Encoding_Error (Iptr - 2); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suenco.ads b/gcc/ada/a-suenco.ads new file mode 100755 index 00000000000..0aa4f88b20f --- /dev/null +++ b/gcc/ada/a-suenco.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It provides conversions +-- from one UTF encoding method to another. Note: this package is consistent +-- with Ada 95, and may be used in Ada 95 or Ada 2005 mode. + +package Ada.Strings.UTF_Encoding.Conversions is + pragma Pure (Conversions); + + -- In the following conversion routines, a BOM in the input that matches + -- the encoding scheme is ignored, an incorrect BOM causes Encoding_Error + -- to be raised. A BOM is present in the output if the Output_BOM parameter + -- is set to True. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in one of + -- these three schemes as specified by the Output_Scheme argument. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in UTF-16. + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from UTF-8 to UTF-16 + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from UTF-16 to UTF-8, UTF-16LE, or UTF-16BE as specified by + -- the Output_Scheme argument. + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Convert from UTF-16 to UTF-8 + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suewen.adb b/gcc/ada/a-suewen.adb new file mode 100755 index 00000000000..3cbebc83d3a --- /dev/null +++ b/gcc/ada/a-suewen.adb @@ -0,0 +1,371 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Encoding is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_String + + function Decode (Item : UTF_8_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input Item pointer + + C : Unsigned_8; + R : Unsigned_16; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_16 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + -- Such codes are out of range for Wide_String output + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result is same length as input (possibly minus 1 if BOM present) + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Index of next Item element + + C : Unsigned_16; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- Such codes are out of range for 16-bit output. + + -- The case of input in the range 16#DC00#..16#DFFF# must never + -- occur, since it means we have a second surrogate character with + -- no corresponding first surrogate. + + -- Codes in the range 16#FFFE# .. 16#FFFF# are also invalid since + -- they conflict with codes used for BOM values. + + -- Thus all remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Case of UTF_8 + + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + + -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary + + else + return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), + Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_String in UTF-8 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is three bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_16; + -- Single input character + + procedure Store (C : Unsigned_16); + pragma Inline (Store); + -- Store one output code, C is in the range 0 .. 255 + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_16) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for UTF8_Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for J in Item'Range loop + C := To_Unsigned_16 (Item (J)); + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + else + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_String in UTF-16 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : Wide_String (1 .. Item'Length + Boolean'Pos (Output_BOM)); + -- Output is same length as input + possible BOM + + Len : Integer; + -- Length of output string + + C : Unsigned_16; + + begin + -- Output BOM if required + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_16 (Item (Iptr)); + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# are + -- output unchaned. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in tne range 16#D800#..16#DFFF# should never appear in the + -- input, since no valid Unicode characters are in this range (which + -- would conflict with the UTF-16 surrogate encodings). Similarly + -- codes in the range 16#FFFE#..16#FFFF conflict with BOM codes. + -- Thus all remaining codes are illegal. + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result; + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Encoding; diff --git a/gcc/ada/a-suewen.ads b/gcc/ada/a-suewen.ads new file mode 100755 index 00000000000..bae9e148447 --- /dev/null +++ b/gcc/ada/a-suewen.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 95, and may be included in Ada 95 implementations. + +package Ada.Strings.UTF_Encoding.Wide_Encoding is + pragma Pure (Wide_Encoding); + + -- The encoding routines take a Wide_String as input and encode the result + -- using the specified UTF encoding method. The result includes a BOM if + -- the Output_BOM argument is set to True. Encoding_Error is raised if an + -- invalid character appears in the input. In particular the characters + -- in the range 16#D800# .. 16#DFFF# are invalid because they conflict + -- with UTF-16 surrogate encodings, and the characters 16#FFFE# and + -- 16#FFFF# are also invalid because they conflict with BOM codes. + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_String + -- value. Note: a convenient form for scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Encoding; diff --git a/gcc/ada/a-suezen.adb b/gcc/ada/a-suezen.adb new file mode 100755 index 00000000000..972fbf061e8 --- /dev/null +++ b/gcc/ada/a-suezen.adb @@ -0,0 +1,431 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_Wide_String + + function Decode (Item : UTF_8_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input string pointer + + C : Unsigned_8; + R : Unsigned_32; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_32 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_32 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_32 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_32 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#11110_111# then + R := Unsigned_32 (C and 2#00000_111#); + Get_Continuation; + Get_Continuation; + Get_Continuation; + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result cannot be longer than the input string + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Pointer to next element in Item + + C : Unsigned_16; + R : Unsigned_32; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- The first surrogate provides 10 high order bits of the result. + + elsif C <= 16#DBFF# then + R := Shift_Left ((Unsigned_32 (C) - 16#D800#), 10); + + -- Error if at end of string + + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + -- Otherwise next character must be valid low order surrogate + -- which provides the low 10 order bits of the result. + + else + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 16#DC00# .. 16#DFFF# then + Raise_Encoding_Error (Iptr - 1); + + else + R := R or (Unsigned_32 (C) mod 2 ** 10); + + -- The final adjustment is to add 16#01_0000 to get the + -- result back in the required 21 bit range. + + R := R + 16#01_0000#; + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end if; + end if; + + -- Remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + else + return From_UTF_16 (Encode (Item), Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_Wide_String in UTF-8 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : String (1 .. 4 * Item'Length + 3); + -- Worst case is four bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_32; + -- Single input character + + procedure Store (C : Unsigned_32); + pragma Inline (Store); + -- Store one output code (input is in range 0 .. 255) + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_32) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00#..16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80#..16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800#..16#D7FF# or 16#E000#..16#FFFD# are + -- represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C in 16#1_0000# .. 16#10_FFFF# then + Store (2#11110_000# or + Shift_Right (C, 18)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000_000000#, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or + (C and 2#00_111111#)); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_Wide_String in UTF-16 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : Wide_String (1 .. 2 * Item'Length + 1); + -- Worst case is each input character generates two output characters + -- plus one for possible BOM. + + Len : Integer; + -- Length of output string + + C : Unsigned_32; + + begin + -- Output BOM if needed + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00_0000#..16#00_D7FF# or 16#E000#..16#FFFD# + -- are output unchanged + + if C <= 16#00_D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#01_0000#..16#10_FFFF# are output using two + -- surrogate characters. First 16#1_0000# is subtracted from the code + -- point to give a 20-bit value. This is then split into two separate + -- 10-bit values each of which is represented as a surrogate with the + -- most significant half placed in the first surrogate. The ranges of + -- values used for the two surrogates are 16#D800#-16#DBFF# for the + -- first, most significant surrogate and 16#DC00#-16#DFFF# for the + -- second, least significant surrogate. + + elsif C in 16#1_0000# .. 16#10_FFFF# then + C := C - 16#1_0000#; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#D800# + C / 2 ** 10); + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#DC00# + C mod 2 ** 10); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding; diff --git a/gcc/ada/a-suezen.ads b/gcc/ada/a-suezen.ads new file mode 100755 index 00000000000..7d2a91d2b25 --- /dev/null +++ b/gcc/ada/a-suezen.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 2005, and may be used in Ada 2005 mode, but cannot be +-- used in Ada 95 mode, since Wide_Wide_Character is an Ada 2005 feature. + +package Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is + pragma Pure (Wide_Wide_Encoding); + + -- The encoding routines take a Wide_Wide_String as input and encode the + -- result using the specified UTF encoding method. The result includes a + -- BOM if the Output_BOM parameter is set to True. + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_Wide_String + -- value. Note: a convenient form for Scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding; diff --git a/gcc/ada/a-suteio-shared.adb b/gcc/ada/a-suteio-shared.adb new file mode 100644 index 00000000000..d50ed776775 --- /dev/null +++ b/gcc/ada/a-suteio-shared.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; + +package body Ada.Strings.Unbounded.Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Text_IO.File_Type; + Item : out Unbounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/a-swunau-shared.adb b/gcc/ada/a-swunau-shared.adb new file mode 100644 index 00000000000..ad397b8c5b3 --- /dev/null +++ b/gcc/ada/a-swunau-shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Unbounded.Aux is + + --------------------- + -- Get_Wide_String -- + --------------------- + + procedure Get_Wide_String + (U : Unbounded_Wide_String; + S : out Big_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_String; + + --------------------- + -- Set_Wide_String -- + --------------------- + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access) + is + X : Wide_String_Access := S; + + begin + Set_Unbounded_Wide_String (UP, S.all); + Free (X); + end Set_Wide_String; + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swunau.adb b/gcc/ada/a-swunau.adb index 59eb3f6cf22..004a5d4ac1a 100644 --- a/gcc/ada/a-swunau.adb +++ b/gcc/ada/a-swunau.adb @@ -37,11 +37,14 @@ package body Ada.Strings.Wide_Unbounded.Aux is procedure Get_Wide_String (U : Unbounded_Wide_String; - S : out Wide_String_Access; + S : out Big_Wide_String_Access; L : out Natural) is + X : aliased Big_Wide_String; + for X'Address use U.Reference.all'Address; + begin - S := U.Reference; + S := X'Unchecked_Access; L := U.Last; end Get_Wide_String; @@ -51,20 +54,6 @@ package body Ada.Strings.Wide_Unbounded.Aux is procedure Set_Wide_String (UP : in out Unbounded_Wide_String; - S : Wide_String) - is - begin - if S'Length > UP.Last then - Finalize (UP); - UP.Reference := new Wide_String (1 .. S'Length); - end if; - - UP.Reference (1 .. S'Length) := S; - UP.Last := S'Length; - end Set_Wide_String; - - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; S : Wide_String_Access) is begin diff --git a/gcc/ada/a-swunau.ads b/gcc/ada/a-swunau.ads index 6df205c0293..78fa5dbb865 100644 --- a/gcc/ada/a-swunau.ads +++ b/gcc/ada/a-swunau.ads @@ -37,9 +37,12 @@ package Ada.Strings.Wide_Unbounded.Aux is pragma Preelaborate; + subtype Big_Wide_String is Wide_String (Positive'Range); + type Big_Wide_String_Access is access all Big_Wide_String; + procedure Get_Wide_String (U : Unbounded_Wide_String; - S : out Wide_String_Access; + S : out Big_Wide_String_Access; L : out Natural); pragma Inline (Get_Wide_String); -- This procedure returns the internal string pointer used in the @@ -54,10 +57,8 @@ package Ada.Strings.Wide_Unbounded.Aux is -- referenced string returned by this call is always one, so the actual -- string data is always accessible as S (1 .. L). - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; - S : Wide_String); - pragma Inline (Set_Wide_String); + procedure Set_Wide_String (UP : out Unbounded_Wide_String; S : Wide_String) + renames Set_Unbounded_Wide_String; -- This function sets the string contents of the referenced unbounded -- string to the given string value. It is significantly more efficient -- than the use of To_Unbounded_Wide_String with an assignment, since it diff --git a/gcc/ada/a-swuwti-shared.adb b/gcc/ada/a-swuwti-shared.adb new file mode 100644 index 00000000000..9cf7c0ad559 --- /dev/null +++ b/gcc/ada/a-swuwti-shared.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; + +package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_String is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/a-szunau-shared.adb b/gcc/ada/a-szunau-shared.adb new file mode 100644 index 00000000000..87b2cb40d15 --- /dev/null +++ b/gcc/ada/a-szunau-shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Wide_Unbounded.Aux is + + -------------------------- + -- Get_Wide_Wide_String -- + -------------------------- + + procedure Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String; + S : out Big_Wide_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_Wide_String; + + -------------------------- + -- Set_Wide_Wide_String -- + -------------------------- + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access) + is + X : Wide_Wide_String_Access := S; + + begin + Set_Unbounded_Wide_Wide_String (UP, S.all); + Free (X); + end Set_Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szunau.adb b/gcc/ada/a-szunau.adb index 64e52507ce7..7ab9cc5acd4 100644 --- a/gcc/ada/a-szunau.adb +++ b/gcc/ada/a-szunau.adb @@ -31,37 +31,26 @@ package body Ada.Strings.Wide_Wide_Unbounded.Aux is - -------------------- + -------------------------- -- Get_Wide_Wide_String -- - --------------------- + -------------------------- procedure Get_Wide_Wide_String (U : Unbounded_Wide_Wide_String; - S : out Wide_Wide_String_Access; + S : out Big_Wide_Wide_String_Access; L : out Natural) is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.all'Address; + begin - S := U.Reference; + S := X'Unchecked_Access; L := U.Last; end Get_Wide_Wide_String; - --------------------- + -------------------------- -- Set_Wide_Wide_String -- - --------------------- - - procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String) - is - begin - if S'Length > UP.Last then - Finalize (UP); - UP.Reference := new Wide_Wide_String (1 .. S'Length); - end if; - - UP.Reference (1 .. S'Length) := S; - UP.Last := S'Length; - end Set_Wide_Wide_String; + -------------------------- procedure Set_Wide_Wide_String (UP : in out Unbounded_Wide_Wide_String; diff --git a/gcc/ada/a-szunau.ads b/gcc/ada/a-szunau.ads index 913c0e136d7..6115330d94b 100644 --- a/gcc/ada/a-szunau.ads +++ b/gcc/ada/a-szunau.ads @@ -37,9 +37,12 @@ package Ada.Strings.Wide_Wide_Unbounded.Aux is pragma Preelaborate; + subtype Big_Wide_Wide_String is Wide_Wide_String (Positive); + type Big_Wide_Wide_String_Access is access all Big_Wide_Wide_String; + procedure Get_Wide_Wide_String (U : Unbounded_Wide_Wide_String; - S : out Wide_Wide_String_Access; + S : out Big_Wide_Wide_String_Access; L : out Natural); pragma Inline (Get_Wide_Wide_String); -- This procedure returns the internal string pointer used in the @@ -55,9 +58,9 @@ package Ada.Strings.Wide_Wide_Unbounded.Aux is -- string data is always accessible as S (1 .. L). procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String); - pragma Inline (Set_Wide_Wide_String); + (UP : out Unbounded_Wide_Wide_String; + S : Wide_Wide_String) + renames Set_Unbounded_Wide_Wide_String; -- This function sets the string contents of the referenced unbounded -- string to the given string value. It is significantly more efficient -- than the use of To_Unbounded_Wide_Wide_String with an assignment, since diff --git a/gcc/ada/a-szuzti-shared.adb b/gcc/ada/a-szuzti-shared.adb new file mode 100644 index 00000000000..247ccb2bcd5 --- /dev/null +++ b/gcc/ada/a-szuzti-shared.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; + +package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 63d694e87a6..7ef214bf83c 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -101,7 +101,7 @@ private -- +-------------------+ -- | hash table link | -- +-------------------+ - -- | remotely callable | + -- | transportable | -- +-------------------+ -- | rec ctrler offset | -- +-------------------+ diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb index 73ebc006251..82aeb8a83e6 100644 --- a/gcc/ada/a-tifiio.adb +++ b/gcc/ada/a-tifiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -301,10 +301,14 @@ package body Ada.Text_IO.Fixed_IO is (To : out String; Last : out Natural; Item : Num; - Fore : Field; + Fore : Integer; Aft : Field; Exp : Field); - -- Actual output function, used internally by all other Put routines + -- Actual output function, used internally by all other Put routines. + -- The formal Fore is an Integer, not a Field, because the routine is + -- also called from the version of Put that performs I/O to a string, + -- where the starting position depends on the size of the String, and + -- bears no relation to the bounds of Field. --------- -- Get -- @@ -392,7 +396,7 @@ package body Ada.Text_IO.Fixed_IO is Last : Natural; begin - if Fore - Boolean'Pos (Item < 0.0) < 1 or else Fore > Field'Last then + if Fore - Boolean'Pos (Item < 0.0) < 1 then raise Layout_Error; end if; @@ -407,7 +411,7 @@ package body Ada.Text_IO.Fixed_IO is (To : out String; Last : out Natural; Item : Num; - Fore : Field; + Fore : Integer; Aft : Field; Exp : Field) is diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 54b32232bb8..9b814e945d0 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, 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- * @@ -132,7 +132,7 @@ UINT CurrentCodePage; #include <sys/wait.h> #endif -#if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) +#if defined (_WIN32) #elif defined (VMS) /* Header files and definitions for __gnat_set_file_time_name. */ @@ -183,7 +183,7 @@ struct vstring #include <utime.h> #endif -#if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) +#if defined (_WIN32) #include <process.h> #endif @@ -205,14 +205,6 @@ struct vstring external file mapped to LF in internal file), but in Unix-like systems, no text translation is required, so these flags have no effect. */ -#if defined (__EMX__) -#include <os2.h> -#endif - -#if defined (MSDOS) -#include <dos.h> -#endif - #ifndef O_BINARY #define O_BINARY 0 #endif @@ -275,9 +267,7 @@ char __gnat_path_separator = PATH_SEPARATOR; as well. This is only a temporary work-around for 3.11b. */ #ifndef GNAT_LIBRARY_TEMPLATE -#if defined (__EMX__) -#define GNAT_LIBRARY_TEMPLATE "*.a" -#elif defined (VMS) +#if defined (VMS) #define GNAT_LIBRARY_TEMPLATE "*.olb" #else #define GNAT_LIBRARY_TEMPLATE "lib*.a" @@ -294,10 +284,7 @@ const int __gnat_vmsp = 1; const int __gnat_vmsp = 0; #endif -#ifdef __EMX__ -#define GNAT_MAX_PATH_LEN MAX_PATH - -#elif defined (VMS) +#if defined (VMS) #define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */ #elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__) @@ -377,7 +364,7 @@ to_ptr32 (char **ptr64) #define MAYBE_TO_PTR32(argv) argv #endif -const char ATTR_UNSET = 127; +static const char ATTR_UNSET = 127; void __gnat_reset_attributes @@ -478,8 +465,8 @@ __gnat_readlink (char *path ATTRIBUTE_UNUSED, char *buf ATTRIBUTE_UNUSED, size_t bufsiz ATTRIBUTE_UNUSED) { -#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \ - || defined (VMS) || defined(__vxworks) || defined (__nucleus__) +#if defined (_WIN32) || defined (VMS) \ + || defined(__vxworks) || defined (__nucleus__) return -1; #else return readlink (path, buf, bufsiz); @@ -494,8 +481,8 @@ int __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, char *newpath ATTRIBUTE_UNUSED) { -#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__) \ - || defined (VMS) || defined(__vxworks) || defined (__nucleus__) +#if defined (_WIN32) || defined (VMS) \ + || defined(__vxworks) || defined (__nucleus__) return -1; #else return symlink (oldpath, newpath); @@ -504,8 +491,8 @@ __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, /* Try to lock a file, return 1 if success. */ -#if defined (__vxworks) || defined (__nucleus__) || defined (MSDOS) \ - || defined (_WIN32) || defined (__EMX__) || defined (VMS) +#if defined (__vxworks) || defined (__nucleus__) \ + || defined (_WIN32) || defined (VMS) /* Version that does not use link. */ @@ -577,9 +564,7 @@ __gnat_try_lock (char *dir, char *file) int __gnat_get_maximum_file_name_length (void) { -#if defined (MSDOS) - return 8; -#elif defined (VMS) +#if defined (VMS) if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS")) return -1; else @@ -594,7 +579,7 @@ __gnat_get_maximum_file_name_length (void) int __gnat_get_file_names_case_sensitive (void) { -#if defined (__EMX__) || defined (MSDOS) || defined (VMS) || defined (WINNT) +#if defined (VMS) || defined (WINNT) return 0; #else return 1; @@ -604,11 +589,7 @@ __gnat_get_file_names_case_sensitive (void) char __gnat_get_default_identifier_character_set (void) { -#if defined (__EMX__) || defined (MSDOS) - return 'p'; -#else return '1'; -#endif } /* Return the current working directory. */ @@ -675,12 +656,7 @@ __gnat_get_executable_suffix_ptr (int *len, const char **value) void __gnat_get_debuggable_suffix_ptr (int *len, const char **value) { -#ifndef MSDOS *value = HOST_EXECUTABLE_SUFFIX; -#else - /* On DOS, the extensionless COFF file is what gdb likes. */ - *value = ""; -#endif if (*value == 0) *len = 0; @@ -859,7 +835,7 @@ __gnat_open_read (char *path, int fmode) return fd < 0 ? -1 : fd; } -#if defined (__EMX__) || defined (__MINGW32__) +#if defined (__MINGW32__) #define PERM (S_IREAD | S_IWRITE) #elif defined (VMS) /* Excerpt from DECC C RTL Reference Manual: @@ -1101,7 +1077,7 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) attr->executable = (!ret && (statbuf.st_mode & S_IXUSR)); #endif -#if !defined (__EMX__) && !defined (MSDOS) && (!defined (_WIN32) || defined (RTX)) +#if !defined (_WIN32) || defined (RTX) /* on Windows requires extra system call, see __gnat_file_time_name_attr */ if (ret != 0) { attr->timestamp = (OS_Time)-1; @@ -1342,13 +1318,7 @@ OS_Time __gnat_file_time_name_attr (char* name, struct file_attributes* attr) { if (attr->timestamp == (OS_Time)-2) { -#if defined (__EMX__) || defined (MSDOS) - int fd = open (name, O_RDONLY | O_BINARY); - time_t ret = __gnat_file_time_fd (fd); - close (fd); - attr->timestamp = (OS_Time)ret; - -#elif defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) && !defined (RTX) time_t ret = -1; TCHAR wname[GNAT_MAX_PATH_LEN]; S2WSC (wname, name, GNAT_MAX_PATH_LEN); @@ -1383,74 +1353,7 @@ OS_Time __gnat_file_time_fd_attr (int fd, struct file_attributes* attr) { if (attr->timestamp == (OS_Time)-2) { - /* The following workaround code is due to the fact that under EMX and - DJGPP fstat attempts to convert time values to GMT rather than keep the - actual OS timestamp of the file. By using the OS2/DOS functions directly - the GNAT timestamp are independent of this behavior, which is desired to - facilitate the distribution of GNAT compiled libraries. */ - -#if defined (__EMX__) || defined (MSDOS) -#ifdef __EMX__ - - FILESTATUS fs; - int ret = DosQueryFileInfo (fd, 1, (unsigned char *) &fs, - sizeof (FILESTATUS)); - - unsigned file_year = fs.fdateLastWrite.year; - unsigned file_month = fs.fdateLastWrite.month; - unsigned file_day = fs.fdateLastWrite.day; - unsigned file_hour = fs.ftimeLastWrite.hours; - unsigned file_min = fs.ftimeLastWrite.minutes; - unsigned file_tsec = fs.ftimeLastWrite.twosecs; - -#else - struct ftime fs; - int ret = getftime (fd, &fs); - - unsigned file_year = fs.ft_year; - unsigned file_month = fs.ft_month; - unsigned file_day = fs.ft_day; - unsigned file_hour = fs.ft_hour; - unsigned file_min = fs.ft_min; - unsigned file_tsec = fs.ft_tsec; -#endif - - /* Calculate the seconds since epoch from the time components. First count - the whole days passed. The value for years returned by the DOS and OS2 - functions count years from 1980, so to compensate for the UNIX epoch which - begins in 1970 start with 10 years worth of days and add days for each - four year period since then. */ - - time_t tot_secs; - int cum_days[12] = {0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334}; - int days_passed = 3652 + (file_year / 4) * 1461; - int years_since_leap = file_year % 4; - - if (years_since_leap == 1) - days_passed += 366; - else if (years_since_leap == 2) - days_passed += 731; - else if (years_since_leap == 3) - days_passed += 1096; - - if (file_year > 20) - days_passed -= 1; - - days_passed += cum_days[file_month - 1]; - if (years_since_leap == 0 && file_year != 20 && file_month > 2) - days_passed++; - - days_passed += file_day - 1; - - /* OK - have whole days. Multiply -- then add in other parts. */ - - tot_secs = days_passed * 86400; - tot_secs += file_hour * 3600; - tot_secs += file_min * 60; - tot_secs += file_tsec * 2; - attr->timestamp = (OS_Time) tot_secs; - -#elif defined (_WIN32) && !defined (RTX) +#if defined (_WIN32) && !defined (RTX) HANDLE h = (HANDLE) _get_osfhandle (fd); time_t ret = win32_filetime (h); attr->timestamp = (OS_Time) ret; @@ -1476,7 +1379,7 @@ __gnat_file_time_fd (int fd) void __gnat_set_file_time_name (char *name, time_t time_stamp) { -#if defined (__EMX__) || defined (MSDOS) || defined (__vxworks) +#if defined (__vxworks) /* Code to implement __gnat_set_file_time_name for these systems. */ @@ -1857,7 +1760,7 @@ __gnat_is_absolute_path (char *name, int length) #else return (length != 0) && (*name == '/' || *name == DIR_SEPARATOR -#if defined (__EMX__) || defined (MSDOS) || defined (WINNT) +#if defined (WINNT) || (length > 1 && ISALPHA (name[0]) && name[1] == ':') #endif ); @@ -2358,7 +2261,7 @@ __gnat_portable_spawn (char *args[]) #if defined (__vxworks) || defined(__nucleus__) || defined(RTX) return -1; -#elif defined (MSDOS) || defined (_WIN32) +#elif defined (_WIN32) /* args[0] must be quotes as it could contain a full pathname with spaces */ char *args_0 = args[0]; args[0] = (char *)xmalloc (strlen (args_0) + 3); @@ -2379,12 +2282,6 @@ __gnat_portable_spawn (char *args[]) #else -#ifdef __EMX__ - pid = spawnvp (P_NOWAIT, args[0], args); - if (pid == -1) - return -1; - -#else pid = fork (); if (pid < 0) return -1; @@ -2399,7 +2296,6 @@ __gnat_portable_spawn (char *args[]) _exit (1); #endif } -#endif /* The parent. */ finished = waitpid (pid, &status, 0); @@ -2474,7 +2370,7 @@ static HANDLE *HANDLES_LIST = NULL; static int *PID_LIST = NULL, plist_length = 0, plist_max_length = 0; static void -add_handle (HANDLE h) +add_handle (HANDLE h, int pid) { /* -------------------- critical section -------------------- */ @@ -2490,7 +2386,7 @@ add_handle (HANDLE h) } HANDLES_LIST[plist_length] = h; - PID_LIST[plist_length] = GetProcessId (h); + PID_LIST[plist_length] = pid; ++plist_length; (*Unlock_Task) (); @@ -2521,8 +2417,8 @@ __gnat_win32_remove_handle (HANDLE h, int pid) /* -------------------- critical section -------------------- */ } -static HANDLE -win32_no_block_spawn (char *command, char *args[]) +static void +win32_no_block_spawn (char *command, char *args[], HANDLE *h, int *pid) { BOOL result; STARTUPINFO SI; @@ -2587,10 +2483,14 @@ win32_no_block_spawn (char *command, char *args[]) if (result == TRUE) { CloseHandle (PI.hThread); - return PI.hProcess; + *h = PI.hProcess; + *pid = PI.dwProcessId; } else - return NULL; + { + *h = NULL; + *pid = 0; + } } static int @@ -2627,7 +2527,7 @@ win32_wait (int *status) h = hl[res - WAIT_OBJECT_0]; GetExitCodeProcess (h, &exitcode); - pid = GetProcessId (h); + pid = PID_LIST [res - WAIT_OBJECT_0]; __gnat_win32_remove_handle (h, -1); free (hl); @@ -2645,28 +2545,16 @@ __gnat_portable_no_block_spawn (char *args[]) #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) return -1; -#elif defined (__EMX__) || defined (MSDOS) - - /* ??? For PC machines I (Franco) don't know the system calls to implement - this routine. So I'll fake it as follows. This routine will behave - exactly like the blocking portable_spawn and will systematically return - a pid of 0 unless the spawned task did not complete successfully, in - which case we return a pid of -1. To synchronize with this the - portable_wait below systematically returns a pid of 0 and reports that - the subprocess terminated successfully. */ - - if (spawnvp (P_WAIT, args[0], args) != 0) - return -1; - #elif defined (_WIN32) HANDLE h = NULL; + int pid; - h = win32_no_block_spawn (args[0], args); + win32_no_block_spawn (args[0], args, &h, &pid); if (h != NULL) { - add_handle (h); - return GetProcessId (h); + add_handle (h, pid); + return pid; } else return -1; @@ -2698,16 +2586,12 @@ __gnat_portable_wait (int *process_status) int pid = 0; #if defined (__vxworks) || defined (__nucleus__) || defined (RTX) - /* Not sure what to do here, so do same as __EMX__ case, i.e., nothing but - return zero. */ + /* Not sure what to do here, so do nothing but return zero. */ #elif defined (_WIN32) pid = win32_wait (&status); -#elif defined (__EMX__) || defined (MSDOS) - /* ??? See corresponding comment in portable_no_block_spawn. */ - #else pid = waitpid (-1, &status, 0); @@ -2783,12 +2667,6 @@ __gnat_locate_regular_file (char *file_name, char *path_val) for (;;) { - for (; *path_val == PATH_SEPARATOR; path_val++) - ; - - if (*path_val == 0) - return 0; - /* Skip the starting quote */ if (*path_val == '"') @@ -2797,7 +2675,14 @@ __gnat_locate_regular_file (char *file_name, char *path_val) for (ptr = file_path; *path_val && *path_val != PATH_SEPARATOR; ) *ptr++ = *path_val++; - ptr--; + /* If directory is empty, it is the current directory*/ + + if (ptr == file_path) + { + *ptr = '.'; + } + else + ptr--; /* Skip the ending quote */ @@ -2811,6 +2696,13 @@ __gnat_locate_regular_file (char *file_name, char *path_val) if (__gnat_is_regular_file (file_path)) return xstrdup (file_path); + + if (*path_val == 0) + return 0; + + /* Skip path separator */ + + path_val++; } } @@ -3445,14 +3337,6 @@ __gnat_adjust_os_resource_limits (void) #endif -/* For EMX, we cannot include dummy in libgcc, since it is too difficult - to coordinate this with the EMX distribution. Consequently, we put the - definition of dummy which is used for exception handling, here. */ - -#if defined (__EMX__) -void __dummy () {} -#endif - #if defined (__mips_vxworks) int _flush_cache() diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index e996611c327..001d654ff1d 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -220,11 +220,11 @@ package body ALI.Util is null; end Post_Scan; - -------------- - -- Read_ALI -- - -------------- + ---------------------- + -- Read_Withed_ALIs -- + ---------------------- - procedure Read_ALI (Id : ALI_Id) is + procedure Read_Withed_ALIs (Id : ALI_Id) is Afile : File_Name_Type; Text : Text_Buffer_Ptr; Idread : ALI_Id; @@ -298,7 +298,7 @@ package body ALI.Util is else -- Otherwise, recurse to get new dependents - Read_ALI (Idread); + Read_Withed_ALIs (Idread); end if; -- If the ALI file has already been processed and is an interface, @@ -309,7 +309,7 @@ package body ALI.Util is end if; end loop; end loop; - end Read_ALI; + end Read_Withed_ALIs; ---------------------- -- Set_Source_Table -- @@ -481,6 +481,14 @@ package body ALI.Util is (Get_File_Checksum (Sdep.Table (D).Sfile), Source.Table (Src).Checksum) then + if Verbose_Mode then + Write_Str (" "); + Write_Str (Get_Name_String (Sdep.Table (D).Sfile)); + Write_Str (": up to date, different timestamps " & + "but same checksum"); + Write_Eol; + end if; + Sdep.Table (D).Stamp := Source.Table (Src).Stamp; end if; diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads index d28ad40d54d..cbdb14f7075 100644 --- a/gcc/ada/ali-util.ads +++ b/gcc/ada/ali-util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -32,9 +32,8 @@ package ALI.Util is -- Source File Table -- ----------------------- - -- A source file table entry is built for every source file that is - -- in the source dependency table of any of the ALI files that make - -- up the current program. + -- A table entry is built for every source file that is in the source + -- dependency table of any ALI file that is part of the current program. No_Source_Id : constant Source_Id := Source_Id'First; -- Special value indicating no Source table entry @@ -101,11 +100,11 @@ package ALI.Util is -- Subprograms for Manipulating ALI Information -- -------------------------------------------------- - procedure Read_ALI (Id : ALI_Id); - -- Process an ALI file which has been read and scanned by looping - -- through all withed units in the ALI file, checking if they have - -- been processed. Each unit that has not yet been processed will - -- be read, scanned, and processed recursively. + procedure Read_Withed_ALIs (Id : ALI_Id); + -- Process an ALI file which has been read and scanned by looping through + -- all withed units in the ALI file, checking if they have been processed. + -- Each unit that has not yet been processed will be read, scanned, and + -- processed recursively. procedure Set_Source_Table (A : ALI_Id); -- Build source table entry corresponding to the ALI file whose id is A diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 9effd220168..eb45dcaca50 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -1295,9 +1295,9 @@ package body ALI is else Skip_Space; No_Deps.Append ((Id, Get_Name)); + Skip_Eol; end if; - Skip_Eol; C := Getc; end loop; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index de7bd7e9719..807527230af 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -44,6 +44,9 @@ with Tree_IO; use Tree_IO; package body Atree is + Reporting_Proc : Report_Proc := null; + -- Record argument to last call to Set_Reporting_Proc + --------------- -- Debugging -- --------------- @@ -63,13 +66,15 @@ package body Atree is -- Either way, gnat1 will stop when node 12345 is created - -- The second method is faster + -- The second method is much faster + + -- Similarly, rr and rrd allow breaking on rewriting of a given node ww : Node_Id'Base := Node_Id'First - 1; pragma Export (Ada, ww); -- trick the optimizer Watch_Node : Node_Id'Base renames ww; - -- Node to "watch"; that is, whenever a node is created, we check if it is - -- equal to Watch_Node, and if so, call New_Node_Breakpoint. You have + -- Node to "watch"; that is, whenever a node is created, we check if it + -- is equal to Watch_Node, and if so, call New_Node_Breakpoint. You have -- presumably set a breakpoint on New_Node_Breakpoint. Note that the -- initial value of Node_Id'First - 1 ensures that by default, no node -- will be equal to Watch_Node. @@ -89,6 +94,25 @@ package body Atree is -- If Node = Watch_Node, this prints out the new node and calls -- New_Node_Breakpoint. Otherwise, does nothing. + procedure rr; + pragma Export (Ada, rr); + procedure Rewrite_Breakpoint renames rr; + -- This doesn't do anything interesting; it's just for setting breakpoint + -- on as explained above. + + procedure rrd (Old_Node, New_Node : Node_Id); + pragma Export (Ada, rrd); + procedure Rewrite_Debugging_Output + (Old_Node, New_Node : Node_Id) renames rrd; + -- For debugging. If debugging is turned on, Rewrite calls this. If debug + -- flag N is turned on, this prints out the new node. + -- + -- If Old_Node = Watch_Node, this prints out the old and new nodes and + -- calls Rewrite_Breakpoint. Otherwise, does nothing. + + procedure Node_Debug_Output (Op : String; N : Node_Id); + -- Common code for nnd and rrd, writes Op followed by information about N + ----------------------------- -- Local Objects and Types -- ----------------------------- @@ -510,6 +534,13 @@ package body Atree is Orig_Nodes.Set_Last (Nodes.Last); Allocate_List_Tables (Nodes.Last); + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => New_Id, Source => Src); + end if; + return New_Id; end Allocate_Initialize_Node; @@ -823,6 +854,24 @@ package body Atree is end Ekind_In; function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean + is + begin + return T = V1 or else + T = V2 or else + T = V3 or else + T = V4 or else + T = V5 or else + T = V6; + end Ekind_In; + + function Ekind_In (E : Entity_Id; V1 : Entity_Kind; V2 : Entity_Kind) return Boolean @@ -864,6 +913,29 @@ package body Atree is return Ekind_In (Ekind (E), V1, V2, V3, V4, V5); end Ekind_In; + function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean + is + begin + return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6); + end Ekind_In; + + ------------------------ + -- Set_Reporting_Proc -- + ------------------------ + + procedure Set_Reporting_Proc (P : Report_Proc) is + begin + pragma Assert (Reporting_Proc = null); + Reporting_Proc := P; + end Set_Reporting_Proc; + ------------------ -- Error_Posted -- ------------------ @@ -1206,21 +1278,7 @@ package body Atree is begin if Debug_Flag_N or else Node_Is_Watched then - Write_Str ("Allocate "); - - if Nkind (N) in N_Entity then - Write_Str ("entity"); - else - Write_Str ("node"); - end if; - - Write_Str (", Id = "); - Write_Int (Int (N)); - Write_Str (" "); - Write_Location (Sloc (N)); - Write_Str (" "); - Write_Str (Node_Kind'Image (Nkind (N))); - Write_Eol; + Node_Debug_Output ("Allocate", N); if Node_Is_Watched then New_Node_Breakpoint; @@ -1340,6 +1398,7 @@ package body Atree is begin return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9); end Nkind_In; + -------- -- No -- -------- @@ -1349,6 +1408,29 @@ package body Atree is return N = Empty; end No; + ----------------------- + -- Node_Debug_Output -- + ----------------------- + + procedure Node_Debug_Output (Op : String; N : Node_Id) is + begin + Write_Str (Op); + + if Nkind (N) in N_Entity then + Write_Str (" entity"); + else + Write_Str (" node"); + end if; + + Write_Str (" Id = "); + Write_Int (Int (N)); + Write_Str (" "); + Write_Location (Sloc (N)); + Write_Str (" "); + Write_Str (Node_Kind'Image (Nkind (N))); + Write_Eol; + end Node_Debug_Output; + ------------------- -- Nodes_Address -- ------------------- @@ -1508,6 +1590,12 @@ package body Atree is -- to Rewrite if there were an intention to save the original node. Orig_Nodes.Table (Old_Node) := Old_Node; + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); + end if; end Replace; ------------- @@ -1533,6 +1621,7 @@ package body Atree is (not Has_Extension (Old_Node) and not Has_Extension (New_Node) and not Nodes.Table (New_Node).In_List); + pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node)); if Nkind (Old_Node) in N_Subexpr then Old_Paren_Count := Paren_Count (Old_Node); @@ -1565,8 +1654,44 @@ package body Atree is end if; Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); + + -- Invoke the reporting procedure (if available) + + if Reporting_Proc /= null then + Reporting_Proc.all (Target => Old_Node, Source => New_Node); + end if; end Rewrite; + ------------------------- + -- Rewrite_Breakpoint -- + ------------------------- + + procedure rr is -- Rewrite_Breakpoint + begin + Write_Str ("Watched node "); + Write_Int (Int (Watch_Node)); + Write_Str (" rewritten"); + Write_Eol; + end rr; + + ------------------------------ + -- Rewrite_Debugging_Output -- + ------------------------------ + + procedure rrd (Old_Node, New_Node : Node_Id) is -- Rewrite_Debugging_Output + Node_Is_Watched : constant Boolean := Old_Node = Watch_Node; + + begin + if Debug_Flag_N or else Node_Is_Watched then + Node_Debug_Output ("Rewrite", Old_Node); + Node_Debug_Output ("into", New_Node); + + if Node_Is_Watched then + Rewrite_Breakpoint; + end if; + end if; + end rrd; + ------------------ -- Set_Analyzed -- ------------------ diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 2f61374a6e9..11787bc116e 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -461,6 +461,12 @@ package Atree is -- function is used only by Sinfo.CN to change nodes into their -- corresponding entities. + type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id); + + procedure Set_Reporting_Proc (P : Report_Proc); + -- Register a procedure that is invoked when a node is allocated, replaced + -- or rewritten. + type Traverse_Result is (Abandon, OK, OK_Orig, Skip); -- This is the type of the result returned by the Process function passed -- to Traverse_Func and Traverse_Proc. See below for details. @@ -657,6 +663,15 @@ package Atree is V5 : Entity_Kind) return Boolean; function Ekind_In + (E : Entity_Id; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean; + + function Ekind_In (T : Entity_Kind; V1 : Entity_Kind; V2 : Entity_Kind) return Boolean; @@ -682,6 +697,15 @@ package Atree is V4 : Entity_Kind; V5 : Entity_Kind) return Boolean; + function Ekind_In + (T : Entity_Kind; + V1 : Entity_Kind; + V2 : Entity_Kind; + V3 : Entity_Kind; + V4 : Entity_Kind; + V5 : Entity_Kind; + V6 : Entity_Kind) return Boolean; + pragma Inline (Ekind_In); -- Inline all above functions diff --git a/gcc/ada/back_end.adb b/gcc/ada/back_end.adb index f23a320d1ae..ee93f140796 100644 --- a/gcc/ada/back_end.adb +++ b/gcc/ada/back_end.adb @@ -40,8 +40,29 @@ with Switch.C; use Switch.C; with System; use System; with Types; use Types; +with System.OS_Lib; use System.OS_Lib; + package body Back_End is + type Arg_Array is array (Nat) of Big_String_Ptr; + type Arg_Array_Ptr is access Arg_Array; + -- Types to access compiler arguments + + flag_stack_check : Int; + pragma Import (C, flag_stack_check); + -- Indicates if stack checking is enabled, imported from decl.c + + save_argc : Nat; + pragma Import (C, save_argc); + -- Saved value of argc (number of arguments), imported from misc.c + + save_argv : Arg_Array_Ptr; + pragma Import (C, save_argv); + -- Saved value of argv (argument pointers), imported from misc.c + + function Len_Arg (Arg : Pos) return Nat; + -- Determine length of argument number Arg on original gnat1 command line + ------------------- -- Call_Back_End -- ------------------- @@ -122,37 +143,33 @@ package body Back_End is gigi_operating_mode => Mode); end Call_Back_End; + ------------- + -- Len_Arg -- + ------------- + + function Len_Arg (Arg : Pos) return Nat is + begin + for J in 1 .. Nat'Last loop + if save_argv (Arg).all (Natural (J)) = ASCII.NUL then + return J - 1; + end if; + end loop; + + raise Program_Error; + end Len_Arg; + ----------------------------- -- Scan_Compiler_Arguments -- ----------------------------- procedure Scan_Compiler_Arguments is - Next_Arg : Pos := 1; - - type Arg_Array is array (Nat) of Big_String_Ptr; - type Arg_Array_Ptr is access Arg_Array; - flag_stack_check : Int; - pragma Import (C, flag_stack_check); - -- Import from toplev.c - - save_argc : Nat; - pragma Import (C, save_argc); - -- Import from toplev.c - - save_argv : Arg_Array_Ptr; - pragma Import (C, save_argv); - -- Import from toplev.c + Next_Arg : Positive; + -- Next argument to be scanned Output_File_Name_Seen : Boolean := False; -- Set to True after having scanned file_name for switch "-gnatO file" - -- Local functions - - function Len_Arg (Arg : Pos) return Nat; - -- Determine length of argument number Arg on the original command line - -- from gnat1. - procedure Scan_Back_End_Switches (Switch_Chars : String); -- Procedure to scan out switches stored in Switch_Chars. The first -- character is known to be a valid switch character, and there are no @@ -165,21 +182,6 @@ package body Back_End is -- switches must still be scanned to skip "-o" or internal GCC switches -- with their argument. - ------------- - -- Len_Arg -- - ------------- - - function Len_Arg (Arg : Pos) return Nat is - begin - for J in 1 .. Nat'Last loop - if save_argv (Arg).all (Natural (J)) = ASCII.NUL then - return J - 1; - end if; - end loop; - - raise Program_Error; - end Len_Arg; - ---------------------------- -- Scan_Back_End_Switches -- ---------------------------- @@ -222,6 +224,11 @@ package body Back_End is end if; end Scan_Back_End_Switches; + -- Local variables + + Arg_Count : constant Natural := Natural (save_argc - 1); + Args : Argument_List (1 .. Arg_Count); + -- Start of processing for Scan_Compiler_Arguments begin @@ -229,14 +236,25 @@ package body Back_End is Opt.Stack_Checking_Enabled := (flag_stack_check /= 0); - -- Loop through command line arguments, storing them for later access + -- Put the arguments in Args - while Next_Arg < save_argc loop - Look_At_Arg : declare - Argv_Ptr : constant Big_String_Ptr := save_argv (Next_Arg); - Argv_Len : constant Nat := Len_Arg (Next_Arg); + for Arg in Pos range 1 .. save_argc - 1 loop + declare + Argv_Ptr : constant Big_String_Ptr := save_argv (Arg); + Argv_Len : constant Nat := Len_Arg (Arg); Argv : constant String := Argv_Ptr (1 .. Natural (Argv_Len)); + begin + Args (Positive (Arg)) := new String'(Argv); + end; + end loop; + + -- Loop through command line arguments, storing them for later access + + Next_Arg := 1; + while Next_Arg <= Args'Last loop + Look_At_Arg : declare + Argv : constant String := Args (Next_Arg).all; begin -- If the previous switch has set the Output_File_Name_Present @@ -283,7 +301,7 @@ package body Back_End is Opt.No_Stdlib := True; elsif Is_Front_End_Switch (Argv) then - Scan_Front_End_Switches (Argv); + Scan_Front_End_Switches (Argv, Args, Next_Arg); -- All non-front-end switches are back-end switches @@ -295,5 +313,4 @@ package body Back_End is Next_Arg := Next_Arg + 1; end loop; end Scan_Compiler_Arguments; - end Back_End; diff --git a/gcc/ada/back_end.ads b/gcc/ada/back_end.ads index 19144a1128d..fb11939a064 100644 --- a/gcc/ada/back_end.ads +++ b/gcc/ada/back_end.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 3a85ae85e11..f4681906df1 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -224,25 +224,25 @@ package body Binde is After : Unit_Id; R : Succ_Reason; Ea_Id : Elab_All_Id := No_Elab_All_Link); - -- Establish a successor link, Before must be elaborated before After, - -- and the reason for the link is R. Ea_Id is the contents to be placed - -- in the Elab_All_Link of the entry. + -- Establish a successor link, Before must be elaborated before After, and + -- the reason for the link is R. Ea_Id is the contents to be placed in the + -- Elab_All_Link of the entry. procedure Choose (Chosen : Unit_Id); - -- Chosen is the next entry chosen in the elaboration order. This - -- procedure updates all data structures appropriately. + -- Chosen is the next entry chosen in the elaboration order. This procedure + -- updates all data structures appropriately. function Corresponding_Body (U : Unit_Id) return Unit_Id; pragma Inline (Corresponding_Body); - -- Given a unit which is a spec for which there is a separate body, - -- return the unit id of the body. It is an error to call this routine - -- with a unit that is not a spec, or which does not have a separate body. + -- Given a unit which is a spec for which there is a separate body, return + -- the unit id of the body. It is an error to call this routine with a unit + -- that is not a spec, or which does not have a separate body. function Corresponding_Spec (U : Unit_Id) return Unit_Id; pragma Inline (Corresponding_Spec); - -- Given a unit which is a body for which there is a separate spec, - -- return the unit id of the spec. It is an error to call this routine - -- with a unit that is not a body, or which does not have a separate spec. + -- Given a unit which is a body for which there is a separate spec, return + -- the unit id of the spec. It is an error to call this routine with a unit + -- that is not a body, or which does not have a separate spec. procedure Diagnose_Elaboration_Problem; -- Called when no elaboration order can be found. Outputs an appropriate @@ -276,6 +276,10 @@ package body Binde is pragma Inline (Is_Body_Unit); -- Determines if given unit is a body + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean; + -- Returns True if corresponding unit is Pure or Preelaborate. Includes + -- dealing with testing flags on spec if it is given a body. + function Is_Waiting_Body (U : Unit_Id) return Boolean; pragma Inline (Is_Waiting_Body); -- Determines if U is a waiting body, defined as a body which has @@ -286,16 +290,16 @@ package body Binde is Link : Elab_All_Id) return Elab_All_Id; -- Make an Elab_All_Entries table entry with the given Unam and Link - function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; - -- This function uses the Info field set in the names table to obtain - -- the unit Id of a unit, given its name id value. - - function Worse_Choice (U1, U2 : Unit_Id) return Boolean; + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean; -- This is like Better_Choice, and has the same interface, but returns - -- true if U1 is a worse choice than U2 in the sense of the -h (horrible + -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic -- elaboration order) switch. We still have to obey Ada rules, so it is -- not quite the direct inverse of Better_Choice. + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; + -- This function uses the Info field set in the names table to obtain + -- the unit Id of a unit, given its name id value. + procedure Write_Dependencies; -- Write out dependencies (called only if appropriate option is set) @@ -323,7 +327,7 @@ package body Binde is -- Note: the checks here are applied in sequence, and the ordering is -- significant (i.e. the more important criteria are applied first). - -- Prefer a waiting body to any other case + -- Prefer a waiting body to one that is not a waiting body if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then if Debug_Flag_B then @@ -370,6 +374,28 @@ package body Binde is return False; + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + -- Prefer a body to a spec elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then @@ -1141,7 +1167,7 @@ package body Binde is or else ((not Pessimistic_Elab_Order) and then Better_Choice (U, Best_So_Far)) or else (Pessimistic_Elab_Order - and then Worse_Choice (U, Best_So_Far)) + and then Pessimistic_Better_Choice (U, Best_So_Far)) then if Debug_Flag_N then Write_Str (" tentatively chosen (best so far)"); @@ -1321,6 +1347,28 @@ package body Binde is or else Units.Table (U).Utype = Is_Body_Only; end Is_Body_Unit; + ----------------------------- + -- Is_Pure_Or_Preelab_Unit -- + ----------------------------- + + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is + begin + -- If we have a body with separate spec, test flags on the spec + + if Units.Table (U).Utype = Is_Body then + return Units.Table (U + 1).Preelab + or else + Units.Table (U + 1).Pure; + + -- Otherwise we have a spec or body acting as spec, test flags on unit + + else + return Units.Table (U).Preelab + or else + Units.Table (U).Pure; + end if; + end Is_Pure_Or_Preelab_Unit; + --------------------- -- Is_Waiting_Body -- --------------------- @@ -1346,51 +1394,115 @@ package body Binde is return Elab_All_Entries.Last; end Make_Elab_Entry; - ---------------- - -- Unit_Id_Of -- - ---------------- - - function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is - Info : constant Int := Get_Name_Table_Info (Uname); - begin - pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); - return Unit_Id (Info); - end Unit_Id_Of; - - ------------------ - -- Worse_Choice -- - ------------------ + ------------------------------- + -- Pessimistic_Better_Choice -- + ------------------------------- - function Worse_Choice (U1, U2 : Unit_Id) return Boolean is + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is UT1 : Unit_Record renames Units.Table (U1); UT2 : Unit_Record renames Units.Table (U2); begin + if Debug_Flag_B then + Write_Str ("Pessimistic_Better_Choice ("); + Write_Unit_Name (UT1.Uname); + Write_Str (", "); + Write_Unit_Name (UT2.Uname); + Write_Line (")"); + end if; + -- Note: the checks here are applied in sequence, and the ordering is -- significant (i.e. the more important criteria are applied first). - -- If either unit is internal, then use Better_Choice, since the - -- language requires that predefined units not mess up in the choice - -- of elaboration order, and for internal units, any problems are - -- ours and not the programmers. + -- If either unit is predefined or internal, then we use the normal + -- Better_Choice rule, since we don't want to disturb the elaboration + -- rules of the language with -p, same treatment for Pure/Preelab. + + -- Prefer a predefined unit to a non-predefined unit - if UT1.Internal or else UT2.Internal then - return Better_Choice (U1, U2); + if UT1.Predefined and then not UT2.Predefined then + if Debug_Flag_B then + Write_Line (" True: u1 is predefined, u2 is not"); + end if; - -- Prefer anything else to a waiting body (!) + return True; + + elsif UT2.Predefined and then not UT1.Predefined then + if Debug_Flag_B then + Write_Line (" False: u2 is predefined, u1 is not"); + end if; + + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif UT1.Internal and then not UT2.Internal then + if Debug_Flag_B then + Write_Line (" True: u1 is internal, u2 is not"); + end if; + + return True; + + elsif UT2.Internal and then not UT1.Internal then + if Debug_Flag_B then + Write_Line (" False: u2 is internal, u1 is not"); + end if; + + return False; + + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + + -- Prefer anything else to a waiting body. We want to make bodies wait + -- as long as possible, till we are forced to choose them! elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is waiting body, u2 is not"); + end if; + return False; elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is waiting body, u1 is not"); + end if; + return True; -- Prefer a spec to a body (!) elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is body, u2 is not"); + end if; + return False; elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is body, u1 is not"); + end if; + return True; -- If both are waiting bodies, then prefer the one whose spec is @@ -1404,12 +1516,24 @@ package body Binde is -- A before the spec of B if it could. Since it could not, there it -- must be the case that A depends on B. It is therefore a good idea -- to put the body of B last so that if there is an elaboration order - -- problem, we will find it (that's what horrible order is about) + -- problem, we will find it (that's what pssimistic order is about) elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then - return - UNR.Table (Corresponding_Spec (U1)).Elab_Position < - UNR.Table (Corresponding_Spec (U2)).Elab_Position; + declare + Result : constant Boolean := + UNR.Table (Corresponding_Spec (U1)).Elab_Position < + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True: based on waiting body elab positions"); + else + Write_Line (" False: based on waiting body elab positions"); + end if; + end if; + + return Result; + end; end if; -- Remaining choice rules are disabled by Debug flag -do @@ -1420,44 +1544,81 @@ package body Binde is -- as Elaborate_Body_Desirable. In the normal case, we generally want -- to delay the elaboration of these specs as long as possible, so -- that bodies have better chance of being elaborated closer to the - -- specs. Worse_Choice as usual wants to do the opposite and - -- elaborate such specs as early as possible. + -- specs. Pessimistic_Better_Choice as usual wants to do the opposite + -- and elaborate such specs as early as possible. -- If we have two units, one of which is a spec for which this flag -- is set, and the other is not, we normally prefer to delay the spec - -- for which the flag is set, and so Worse_Choice does the opposite. + -- for which the flag is set, so again Pessimistic_Better_Choice does + -- the opposite. if not UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then + if Debug_Flag_B then + Write_Line (" False: u1 is elab body desirable, u2 is not"); + end if; + return False; elsif not UT2.Elaborate_Body_Desirable and then UT1.Elaborate_Body_Desirable then + if Debug_Flag_B then + Write_Line (" True: u1 is elab body desirable, u2 is not"); + end if; + return True; -- If we have two specs that are both marked as Elaborate_Body -- desirable, we normally prefer the one whose body is nearer to -- being able to be elaborated, based on the Num_Pred count. This -- helps to ensure bodies are as close to specs as possible. As - -- usual, Worse_Choice does the opposite. + -- usual, Pessimistic_Better_Choice does the opposite. elsif UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then - return UNR.Table (Corresponding_Body (U1)).Num_Pred >= - UNR.Table (Corresponding_Body (U2)).Num_Pred; + declare + Result : constant Boolean := + UNR.Table (Corresponding_Body (U1)).Num_Pred >= + UNR.Table (Corresponding_Body (U2)).Num_Pred; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True based on Num_Pred compare"); + else + Write_Line (" False based on Num_Pred compare"); + end if; + end if; + + return Result; + end; end if; end if; -- If we fall through, it means that no preference rule applies, so we -- use alphabetical order to at least give a deterministic result. Since - -- Worse_Choice is in the business of stirring up the order, we will - -- use reverse alphabetical ordering. + -- Pessimistic_Better_Choice is in the business of stirring up the + -- order, we will use reverse alphabetical ordering. + + if Debug_Flag_B then + Write_Line (" choose on reverse alpha order"); + end if; return Uname_Less (UT2.Uname, UT1.Uname); - end Worse_Choice; + end Pessimistic_Better_Choice; + + ---------------- + -- Unit_Id_Of -- + ---------------- + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is + Info : constant Int := Get_Name_Table_Info (Uname); + begin + pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); + return Unit_Id (Info); + end Unit_Id_Of; ------------------------ -- Write_Dependencies -- diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 49179f19fff..3d120161789 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -111,6 +111,7 @@ package body Bindgen is -- Main_Priority : Integer; -- Time_Slice_Value : Integer; + -- Heap_Size : Natural; -- WC_Encoding : Character; -- Locking_Policy : Character; -- Queuing_Policy : Character; @@ -136,6 +137,10 @@ package body Bindgen is -- A value of zero indicates that time slicing should be suppressed. If no -- pragma is present, and no -T switch was used, the value is -1. + -- Heap_Size is the heap to use for memory allocations set by use of a + -- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical. + -- Valid values are 32 and 64. This switch is only available on VMS. + -- WC_Encoding shows the wide character encoding method used for the main -- program. This is one of the encoding letters defined in -- System.WCh_Con.WC_Encoding_Letters. @@ -615,6 +620,15 @@ package body Bindgen is WBI (" Features_Set : Integer;"); WBI (" pragma Import (C, Features_Set, " & """__gnat_features_set"");"); + + if Opt.Heap_Size /= 0 then + WBI (""); + WBI (" Heap_Size : Integer;"); + WBI (" pragma Import (C, Heap_Size, " & + """__gl_heap_size"");"); + + Write_Statement_Buffer; + end if; end if; -- Initialize stack limit variable of the environment task if the @@ -786,6 +800,16 @@ package body Bindgen is WBI (" if Features_Set = 0 then"); WBI (" Set_Features;"); WBI (" end if;"); + + -- Features_Set may twiddle the heap size according to a logical + -- name, but the binder switch must override. + + if Opt.Heap_Size /= 0 then + Set_String (" Heap_Size := "); + Set_Int (Opt.Heap_Size); + Set_Char (';'); + Write_Statement_Buffer; + end if; end if; end if; @@ -1936,10 +1960,14 @@ package body Bindgen is WBI (""); Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list"); + if Object_List_Filename /= null then + Set_List_File (Object_List_Filename.all); + end if; + for E in Elab_Order.First .. Elab_Order.Last loop - -- If not spec that has an associated body, then generate a - -- comment giving the name of the corresponding object file. + -- If not spec that has an associated body, then generate a comment + -- giving the name of the corresponding object file. if (not Units.Table (Elab_Order.Table (E)).SAL_Interface) and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec @@ -1948,8 +1976,8 @@ package body Bindgen is (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name); - -- If the presence of an object file is necessary or if it - -- exists, then use it. + -- If the presence of an object file is necessary or if it exists, + -- then use it. if not Hostparm.Exclude_Missing_Objects or else @@ -1971,8 +1999,7 @@ package body Bindgen is (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile) then - -- Special case for g-trasym.obj, which is not included - -- in libgnat. + -- Special case for g-trasym.obj (not included in libgnat) Get_Name_String (ALIs.Table (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile); @@ -1985,6 +2012,10 @@ package body Bindgen is end if; end loop; + if Object_List_Filename /= null then + Close_List_File; + end if; + -- Add a "-Ldir" for each directory in the object path for J in 1 .. Nb_Dir_In_Obj_Search_Path loop @@ -2002,38 +2033,36 @@ package body Bindgen is -- This sort accomplishes two important purposes: - -- a) All application files are sorted to the front, and all - -- GNAT internal files are sorted to the end. This results - -- in a well defined dividing line between the two sets of - -- files, for the purpose of inserting certain standard - -- library references into the linker arguments list. - - -- b) Given two different units, we sort the linker options so - -- that those from a unit earlier in the elaboration order - -- comes later in the list. This is a heuristic designed - -- to create a more friendly order of linker options when - -- the operations appear in separate units. The idea is that - -- if unit A must be elaborated before unit B, then it is - -- more likely that B references libraries included by A, - -- than vice versa, so we want the libraries included by - -- A to come after the libraries included by B. - - -- These two criteria are implemented by function Lt_Linker_Option. - -- Note that a special case of b) is that specs are elaborated before - -- bodies, so linker options from specs come after linker options - -- for bodies, and again, the assumption is that libraries used by - -- the body are more likely to reference libraries used by the spec, - -- than vice versa. + -- a) All application files are sorted to the front, and all GNAT + -- internal files are sorted to the end. This results in a well + -- defined dividing line between the two sets of files, for the + -- purpose of inserting certain standard library references into + -- the linker arguments list. + + -- b) Given two different units, we sort the linker options so that + -- those from a unit earlier in the elaboration order comes later + -- in the list. This is a heuristic designed to create a more + -- friendly order of linker options when the operations appear in + -- separate units. The idea is that if unit A must be elaborated + -- before unit B, then it is more likely that B references + -- libraries included by A, than vice versa, so we want libraries + -- included by A to come after libraries included by B. + + -- These two criteria are implemented by function Lt_Linker_Option. Note + -- that a special case of b) is that specs are elaborated before bodies, + -- so linker options from specs come after linker options for bodies, + -- and again, the assumption is that libraries used by the body are more + -- likely to reference libraries used by the spec, than vice versa. Sort (Linker_Options.Last, Move_Linker_Option'Access, Lt_Linker_Option'Access); - -- Write user linker options, i.e. the set of linker options that - -- come from all files other than GNAT internal files, Lgnat is - -- left set to point to the first entry from a GNAT internal file, - -- or past the end of the entriers if there are no internal files. + -- Write user linker options, i.e. the set of linker options that come + -- from all files other than GNAT internal files, Lgnat is left set to + -- point to the first entry from a GNAT internal file, or past the end + -- of the entriers if there are no internal files. Lgnat := Linker_Options.Last + 1; @@ -2137,9 +2166,9 @@ package body Bindgen is Set_PSD_Pragma_Table; - -- Override Ada_Bind_File and Bind_Main_Program for VMs since - -- JGNAT only supports Ada code, and the main program is already - -- generated by the compiler. + -- Override Ada_Bind_File and Bind_Main_Program for VMs since JGNAT only + -- supports Ada code, and the main program is already generated by the + -- compiler. if VM_Target /= No_VM then Ada_Bind_File := True; @@ -2271,8 +2300,7 @@ package body Bindgen is WBI (" gnat_envp : System.Address;"); -- If the standard library is not suppressed, these variables - -- are in the runtime data area for easy access from the - -- runtime. + -- are in the run-time data area for easy run time access. if not Suppress_Standard_Library_On_Target then WBI (""); @@ -2467,8 +2495,8 @@ package body Bindgen is if not Cumulative_Restrictions.Set (No_Finalization) then - -- In the Java case, pragma Import C cannot be used, so the - -- standard Ada constructs will be used instead. + -- In the Java case, pragma Import C cannot be used, so the standard + -- Ada constructs will be used instead. if VM_Target = No_VM then WBI (""); @@ -2623,8 +2651,8 @@ package body Bindgen is WBI ("extern void __gnat_stack_usage_initialize (int size);"); end if; - -- Initialize stack limit for the environment task if the stack - -- check method is stack limit and stack check is enabled. + -- Initialize stack limit for the environment task if the stack check + -- method is stack limit and stack check is enabled. if Stack_Check_Limits_On_Target and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) @@ -2658,8 +2686,8 @@ package body Bindgen is if Bind_Main_Program then - -- First deal with argc/argv/envp. In the normal case they - -- are in the run-time library. + -- First deal with argc/argv/envp. In the normal case they are in the + -- run-time library. if not Configurable_Run_Time_On_Target then WBI ("extern int gnat_argc;"); @@ -2672,8 +2700,8 @@ package body Bindgen is elsif not Command_Line_Args_On_Target then null; - -- Otherwise, in the configurable run-time case they are right in - -- the binder file. + -- Otherwise, in the configurable run-time case they are right in the + -- binder file. else WBI ("int gnat_argc;"); @@ -2686,8 +2714,8 @@ package body Bindgen is if not Configurable_Run_Time_On_Target then WBI ("extern int gnat_exit_status;"); - -- If configurable run time and no exit status on target, then - -- the generation of this variables is entirely suppressed. + -- If configurable run time and no exit status on target, then the + -- generation of this variables is entirely suppressed. elsif not Exit_Status_Supported_On_Target then null; @@ -2702,9 +2730,8 @@ package body Bindgen is WBI (""); end if; - -- When suppressing the standard library, the __gnat_break_start - -- routine (for the debugger to get initial control) is defined in - -- this file. + -- When suppressing the standard library, the __gnat_break_start routine + -- (for the debugger to get initial control) is defined in this file. if Suppress_Standard_Library_On_Target then WBI (""); @@ -2728,8 +2755,8 @@ package body Bindgen is Write_Statement_Buffer; end if; - -- Generate the adafinal routine. In no runtime mode, this is - -- not needed, since there is no finalization to do. + -- Generate the adafinal routine. In no runtime mode, this is not + -- needed, since there is no finalization to do. if not Cumulative_Restrictions.Set (No_Finalization) then Gen_Adafinal_C; @@ -2974,9 +3001,9 @@ package body Bindgen is -- unnnnn : constant Integer := 16#hhhhhhhh#; -- pragma Export (C, unnnnn, unam); - -- for each unit, where unam is the unit name suffixed by either B or - -- S for body or spec, with dots replaced by double underscores, and - -- hhhhhhhh is the version number, and nnnnn is a 5-digits serial number. + -- for each unit, where unam is the unit name suffixed by either B or S for + -- body or spec, with dots replaced by double underscores, and hhhhhhhh is + -- the version number, and nnnnn is a 5-digits serial number. procedure Gen_Versions_Ada is Ubuf : String (1 .. 6) := "u00000"; @@ -3046,8 +3073,8 @@ package body Bindgen is -- unsigned unam = 0xhhhhhhhh; - -- for each unit, where unam is the unit name suffixed by either B or - -- S for body or spec, with dots replaced by double underscores. + -- for each unit, where unam is the unit name suffixed by either B or S for + -- body or spec, with dots replaced by double underscores. procedure Gen_Versions_C is begin @@ -3185,9 +3212,9 @@ package body Bindgen is Get_Name_String (Units.Table (First_Unit_Entry).Uname); - -- If this is a child name, return only the name of the child, - -- since we can't have dots in a nested program name. Note that - -- we do not include the %b at the end of the unit name. + -- If this is a child name, return only the name of the child, since + -- we can't have dots in a nested program name. Note that we do not + -- include the %b at the end of the unit name. for J in reverse 1 .. Name_Len - 2 loop if J = 1 or else Name_Buffer (J - 1) = '.' then @@ -3219,12 +3246,12 @@ package body Bindgen is -- no better choice. If some other encoding is required when there is -- no main, it must be set explicitly using -Wx. - -- Note: if the ALI file always passed the wide character encoding - -- of every file, then we could use the encoding of the initial - -- specified file, but this information is passed only for potential - -- main programs. We could fix this sometime, but it is a very minor - -- point (wide character default encoding for [Wide_[Wide_]Text_IO - -- when there is no main program). + -- Note: if the ALI file always passed the wide character encoding of + -- every file, then we could use the encoding of the initial specified + -- file, but this information is passed only for potential main + -- programs. We could fix this sometime, but it is a very minor point + -- (wide character default encoding for [Wide_[Wide_]Text_IO when there + -- is no main program). elsif No_Main_Subprogram then return 'b'; @@ -3255,8 +3282,8 @@ package body Bindgen is Linker_Options.Table (Op2).Internal_File; -- If both internal or both non-internal, sort according to the - -- elaboration position. A unit that is elaborated later should - -- come earlier in the linker options list. + -- elaboration position. A unit that is elaborated later should come + -- earlier in the linker options list. else return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position @@ -3285,9 +3312,9 @@ package body Bindgen is Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); -- This is not a perfect approach, but is the current protocol - -- between the run-time and the binder to indicate that tasking - -- is used: system.os_interface should always be used by any - -- tasking application. + -- between the run-time and the binder to indicate that tasking is + -- used: system.os_interface should always be used by any tasking + -- application. if Name_Buffer (1 .. 19) = "system.os_interface" then With_GNARL := True; diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads index 1bce36d4bb2..96d2e306888 100644 --- a/gcc/ada/bindgen.ads +++ b/gcc/ada/bindgen.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ -- This package contains the routines to output the binder file. This is --- a C program which contains the following: +-- an Ada or C program which contains the following: -- initialization for main program case -- sequence of calls to elaboration routines in appropriate order diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb index 2529c351cf1..06fa354d414 100644 --- a/gcc/ada/bindusg.adb +++ b/gcc/ada/bindusg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -73,9 +73,9 @@ package body Bindusg is Write_Line (" -a Automatically initialize elaboration " & "procedure"); - -- Line for A switch + -- Line for -A switch - Write_Line (" -A Generate binder program in Ada (default)"); + Write_Line (" -A Give list of ALI files in partition"); -- Line for -b switch @@ -87,10 +87,6 @@ package body Bindusg is Write_Line (" -c Check only, no generation of " & "binder output file"); - -- Line for C switch - - Write_Line (" -C Generate binder program in C"); - -- Line for -d switch Write_Line (" -dnn[k|m] Default primary stack " & @@ -120,6 +116,11 @@ package body Bindusg is Write_Line (" -h Output this usage (help) information"); + -- Line for -H switch + + Write_Line (" -Hnn Use nn bit heap where nn is 32 or 64 " & + "(VMS Only)"); + -- Lines for -I switch Write_Line (" -Idir Specify library and source files search path"); @@ -185,7 +186,7 @@ package body Bindusg is -- Line for -R switch Write_Line - (" -R List sources referenced in closure (implies -c)"); + (" -R List sources referenced in closure"); -- Line for -s switch diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index a193c299861..59270e875a9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -1584,9 +1584,7 @@ package body Checks is pragma Assert (Target_Base /= Target_Typ); - Temp : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par); begin Apply_Float_Conversion_Check (Ck_Node, Target_Base); @@ -2743,9 +2741,11 @@ package body Checks is end case; if K = N_Op_And then - Error_Msg_N ("use `AND THEN` instead of AND?", P); + Error_Msg_N -- CODEFIX + ("use `AND THEN` instead of AND?", P); else - Error_Msg_N ("use `OR ELSE` instead of OR?", P); + Error_Msg_N -- CODEFIX + ("use `OR ELSE` instead of OR?", P); end if; -- If not short-circuited, we need the ckeck @@ -3351,6 +3351,14 @@ package body Checks is Indx := Next_Index (Indx); end loop; + -- If the index type is a formal type or derived from + -- one, the bounds are not static. + + if Is_Generic_Type (Root_Type (Etype (Indx))) then + OK := False; + return; + end if; + Determine_Range (Type_Low_Bound (Etype (Indx)), OK1, LL, LU, Assume_Valid); @@ -3370,8 +3378,8 @@ package body Checks is -- For constrained arrays, the minimum value for -- Length is taken from the actual value of the - -- bounds, since the index will be exactly of - -- this subtype. + -- bounds, since the index will be exactly of this + -- subtype. if Is_Constrained (Atyp) then Lor := UI_Max (Uint_0, UL - LU + 1); @@ -3387,7 +3395,7 @@ package body Checks is end; -- No special handling for other attributes - -- Probably more opportunities exist here ??? + -- Probably more opportunities exist here??? when others => OK1 := False; @@ -3408,33 +3416,31 @@ package body Checks is Hir := No_Uint; end case; - -- At this stage, if OK1 is true, then we know that the actual - -- result of the computed expression is in the range Lor .. Hir. - -- We can use this to restrict the possible range of results. + -- At this stage, if OK1 is true, then we know that the actual result of + -- the computed expression is in the range Lor .. Hir. We can use this + -- to restrict the possible range of results. if OK1 then - -- If the refined value of the low bound is greater than the - -- type high bound, then reset it to the more restrictive - -- value. However, we do NOT do this for the case of a modular - -- type where the possible upper bound on the value is above the - -- base type high bound, because that means the result could wrap. + -- If the refined value of the low bound is greater than the type + -- high bound, then reset it to the more restrictive value. However, + -- we do NOT do this for the case of a modular type where the + -- possible upper bound on the value is above the base type high + -- bound, because that means the result could wrap. if Lor > Lo - and then not (Is_Modular_Integer_Type (Typ) - and then Hir > Hbound) + and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound) then Lo := Lor; end if; - -- Similarly, if the refined value of the high bound is less - -- than the value so far, then reset it to the more restrictive - -- value. Again, we do not do this if the refined low bound is - -- negative for a modular type, since this would wrap. + -- Similarly, if the refined value of the high bound is less than the + -- value so far, then reset it to the more restrictive value. Again, + -- we do not do this if the refined low bound is negative for a + -- modular type, since this would wrap. if Hir < Hi - and then not (Is_Modular_Integer_Type (Typ) - and then Lor < Uint_0) + and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0) then Hi := Hir; end if; @@ -3448,8 +3454,8 @@ package body Checks is Determine_Range_Cache_Hi (Cindex) := Hi; return; - -- If any exception occurs, it means that we have some bug in the compiler - -- possibly triggered by a previous error, or by some unforseen peculiar + -- If any exception occurs, it means that we have some bug in the compiler, + -- possibly triggered by a previous error, or by some unforeseen peculiar -- occurrence. However, this is only an optimization attempt, so there is -- really no point in crashing the compiler. Instead we just decide, too -- bad, we can't figure out a range in this case after all. @@ -4707,9 +4713,7 @@ package body Checks is -- Then the conversion itself is replaced by an occurrence of Tnn declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); begin Insert_Actions (N, New_List ( @@ -4860,9 +4864,7 @@ package body Checks is -- the value is non-negative declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); begin Insert_Actions (N, New_List ( @@ -5299,6 +5301,16 @@ package body Checks is return False; end if; + -- If we are in a case eexpression, and not part of the + -- expression, then we return False, since a particular + -- branch may not always be elaborated + + if Nkind (P) = N_Case_Expression + and then N /= Expression (P) + then + return False; + end if; + -- While traversing the parent chain, we find that N -- belongs to a statement, thus it may never appear in -- a declarative region. @@ -6243,11 +6255,18 @@ package body Checks is -- Expr > Typ'Last function Get_E_First_Or_Last - (E : Entity_Id; + (Loc : Source_Ptr; + E : Entity_Id; Indx : Nat; Nam : Name_Id) return Node_Id; - -- Returns expression to compute: + -- Returns an attribute reference -- E'First or E'Last + -- with a source location of Loc. + -- + -- Nam is Name_First or Name_Last, according to which attribute is + -- desired. If Indx is non-zero, it is passed as a literal in the + -- Expressions of the attribute reference (identifying the desired + -- array dimension). function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; @@ -6314,7 +6333,7 @@ package body Checks is Duplicate_Subexpr_No_Checks (Expr)), Right_Opnd => Convert_To (Base_Type (Typ), - Get_E_First_Or_Last (Typ, 0, Name_First))), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))), Right_Opnd => Make_Op_Gt (Loc, @@ -6324,7 +6343,7 @@ package body Checks is Right_Opnd => Convert_To (Base_Type (Typ), - Get_E_First_Or_Last (Typ, 0, Name_Last)))); + Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)))); end Discrete_Expr_Cond; ------------------------- @@ -6362,7 +6381,8 @@ package body Checks is Right_Opnd => Convert_To - (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First))); + (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); if Base_Type (Typ) = Typ then return Left_Opnd; @@ -6397,7 +6417,7 @@ package body Checks is Right_Opnd => Convert_To (Base_Type (Typ), - Get_E_First_Or_Last (Typ, 0, Name_Last))); + Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))); return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); end Discrete_Range_Cond; @@ -6407,115 +6427,23 @@ package body Checks is ------------------------- function Get_E_First_Or_Last - (E : Entity_Id; + (Loc : Source_Ptr; + E : Entity_Id; Indx : Nat; Nam : Name_Id) return Node_Id is - N : Node_Id; - LB : Node_Id; - HB : Node_Id; - Bound : Node_Id; - + Exprs : List_Id; begin - if Is_Array_Type (E) then - N := First_Index (E); - - for J in 2 .. Indx loop - Next_Index (N); - end loop; - - else - N := Scalar_Range (E); - end if; - - if Nkind (N) = N_Subtype_Indication then - LB := Low_Bound (Range_Expression (Constraint (N))); - HB := High_Bound (Range_Expression (Constraint (N))); - - elsif Is_Entity_Name (N) then - LB := Type_Low_Bound (Etype (N)); - HB := Type_High_Bound (Etype (N)); - + if Indx > 0 then + Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx))); else - LB := Low_Bound (N); - HB := High_Bound (N); + Exprs := No_List; end if; - if Nam = Name_First then - Bound := LB; - else - Bound := HB; - end if; - - if Nkind (Bound) = N_Identifier - and then Ekind (Entity (Bound)) = E_Discriminant - then - -- If this is a task discriminant, and we are the body, we must - -- retrieve the corresponding body discriminal. This is another - -- consequence of the early creation of discriminals, and the - -- need to generate constraint checks before their declarations - -- are made visible. - - if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then - declare - Tsk : constant Entity_Id := - Corresponding_Concurrent_Type - (Scope (Entity (Bound))); - Disc : Entity_Id; - - begin - if In_Open_Scopes (Tsk) - and then Has_Completion (Tsk) - then - -- Find discriminant of original task, and use its - -- current discriminal, which is the renaming within - -- the task body. - - Disc := First_Discriminant (Tsk); - while Present (Disc) loop - if Chars (Disc) = Chars (Entity (Bound)) then - Set_Scope (Discriminal (Disc), Tsk); - return New_Occurrence_Of (Discriminal (Disc), Loc); - end if; - - Next_Discriminant (Disc); - end loop; - - -- That loop should always succeed in finding a matching - -- entry and returning. Fatal error if not. - - raise Program_Error; - - else - return - New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); - end if; - end; - else - return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); - end if; - - elsif Nkind (Bound) = N_Identifier - and then Ekind (Entity (Bound)) = E_In_Parameter - and then not Inside_Init_Proc - then - return Get_Discriminal (E, Bound); - - elsif Nkind (Bound) = N_Integer_Literal then - return Make_Integer_Literal (Loc, Intval (Bound)); - - -- Case of a bound rewritten to an N_Raise_Constraint_Error node - -- because it is an out-of-range value. Duplicate_Subexpr cannot be - -- called on this node because an N_Raise_Constraint_Error is not - -- side effect free, and we may not assume that we are in the proper - -- context to remove side effects on it at the point of reference. - - elsif Nkind (Bound) = N_Raise_Constraint_Error then - return New_Copy_Tree (Bound); - - else - return Duplicate_Subexpr_No_Checks (Bound); - end if; + return Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Nam, + Expressions => Exprs); end Get_E_First_Or_Last; ----------------- @@ -6562,13 +6490,17 @@ package body Checks is Make_Or_Else (Loc, Left_Opnd => Make_Op_Lt (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), Right_Opnd => Make_Op_Gt (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_E_Cond; ------------------------ @@ -6585,12 +6517,17 @@ package body Checks is Make_Or_Else (Loc, Left_Opnd => Make_Op_Ne (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), + Right_Opnd => Make_Op_Ne (Loc, - Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + Left_Opnd => + Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_Equal_E_Cond; ------------------ @@ -6607,13 +6544,17 @@ package body Checks is Make_Or_Else (Loc, Left_Opnd => Make_Op_Lt (Loc, - Left_Opnd => Get_N_First (Expr, Indx), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), + Left_Opnd => + Get_N_First (Expr, Indx), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), Right_Opnd => Make_Op_Gt (Loc, - Left_Opnd => Get_N_Last (Expr, Indx), - Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); + Left_Opnd => + Get_N_Last (Expr, Indx), + Right_Opnd => + Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_N_Cond; -- Start of processing for Selected_Range_Checks diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 978a5e7006f..54497274f2d 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, 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- -- @@ -1677,6 +1677,9 @@ package body Clean is new String' (Arg (Subdirs_Option'Length + 1 .. Arg'Last)); + elsif Arg = Makeutl.Unchecked_Shared_Lib_Imports then + Opt.Unchecked_Shared_Lib_Imports := True; + else Bad_Argument; end if; @@ -1957,6 +1960,8 @@ package body Clean is New_Line; Put_Line (" --subdirs=dir real obj/lib/exec dirs are subdirs"); + Put_Line (" " & Makeutl.Unchecked_Shared_Lib_Imports); + Put_Line (" Allow shared libraries to import static libraries"); New_Line; Put_Line (" -c Only delete compiler generated files"); diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb index cd3e0b55a3f..771affc3be0 100644 --- a/gcc/ada/csets.adb +++ b/gcc/ada/csets.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -618,9 +618,9 @@ package body Csets is -- Definitions for IBM PC (Code Page 437) -- -------------------------------------------- - -- Note: Code page 437 is the typical default in DOS, Windows and OS/2 - -- for PC's in the US, it corresponds to the original PC character set. - -- See also the definitions for code page 850. + -- Note: Code page 437 is the typical default in Windows for PC's in the + -- US, it corresponds to the original PC character set. See also the + -- definitions for code page 850. Fold_IBM_PC_437 : constant Translate_Table := Translate_Table'( @@ -752,10 +752,10 @@ package body Csets is -- Definitions for IBM PC (Code Page 850) -- -------------------------------------------- - -- Note: Code page 850 is the typical default in DOS, Windows and OS/2 - -- for PC's in Europe, it is an extension of the original PC character - -- set to include the additional characters defined in ISO Latin-1. - -- See also the definitions for code page 437. + -- Note: Code page 850 is the typical default in Windows for PC's in + -- Europe, it is an extension of the original PC character set to include + -- the additional characters defined in ISO Latin-1. See also the + -- definitions for code page 437. Fold_IBM_PC_850 : constant Translate_Table := Translate_Table'( diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index d6f0ff09cea..9f9332b7241 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -287,11 +287,10 @@ package body CStand is Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String); Set_Etype (First_Entity (Standard_Op_Concatww), - Standard_Wide_Wide_String); + Standard_Wide_Wide_String); Set_Etype (Last_Entity (Standard_Op_Concatww), - Standard_Wide_Wide_String); - + Standard_Wide_Wide_String); end Create_Operators; --------------------- @@ -324,6 +323,10 @@ package body CStand is procedure Build_Exception (S : Standard_Entity_Type); -- Procedure to declare given entity as an exception + procedure Pack_String_Type (String_Type : Entity_Id); + -- Generate proper tree for pragma Pack that applies to given type, and + -- mark type as having the pragma. + --------------------- -- Build_Exception -- --------------------- @@ -341,6 +344,25 @@ package body CStand is Append (Decl, Decl_S); end Build_Exception; + ---------------------- + -- Pack_String_Type -- + ---------------------- + + procedure Pack_String_Type (String_Type : Entity_Id) is + Prag : constant Node_Id := + Make_Pragma (Stloc, + Chars => Name_Pack, + Pragma_Argument_Associations => + New_List ( + Make_Pragma_Argument_Association (Stloc, + Expression => + New_Occurrence_Of (String_Type, Stloc)))); + begin + Append (Prag, Decl_S); + Record_Rep_Item (String_Type, Prag); + Set_Has_Pragma_Pack (String_Type, True); + end Pack_String_Type; + -- Start of processing for Create_Standard begin @@ -688,12 +710,13 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_String), Tdef_Node); - Set_Ekind (Standard_String, E_String_Type); - Set_Etype (Standard_String, Standard_String); - Set_Component_Type (Standard_String, Standard_Character); - Set_Component_Size (Standard_String, Uint_8); - Init_Size_Align (Standard_String); - Set_Alignment (Standard_String, Uint_1); + Set_Ekind (Standard_String, E_String_Type); + Set_Etype (Standard_String, Standard_String); + Set_Component_Type (Standard_String, Standard_Character); + Set_Component_Size (Standard_String, Uint_8); + Init_Size_Align (Standard_String); + Set_Alignment (Standard_String, Uint_1); + Pack_String_Type (Standard_String); -- On targets where a storage unit is larger than a byte (such as AAMP), -- pragma Pack has a real effect on the representation of type String, @@ -731,11 +754,12 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); - Set_Ekind (Standard_Wide_String, E_String_Type); - Set_Etype (Standard_Wide_String, Standard_Wide_String); - Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); - Set_Component_Size (Standard_Wide_String, Uint_16); - Init_Size_Align (Standard_Wide_String); + Set_Ekind (Standard_Wide_String, E_String_Type); + Set_Etype (Standard_Wide_String, Standard_Wide_String); + Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); + Set_Component_Size (Standard_Wide_String, Uint_16); + Init_Size_Align (Standard_Wide_String); + Pack_String_Type (Standard_Wide_String); -- Set index type of Wide_String @@ -772,6 +796,7 @@ package body CStand is Set_Component_Size (Standard_Wide_Wide_String, Uint_32); Init_Size_Align (Standard_Wide_Wide_String); Set_Is_Ada_2005_Only (Standard_Wide_Wide_String); + Pack_String_Type (Standard_Wide_Wide_String); -- Set index type of Wide_Wide_String diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index d57b382a7fb..9dea9a4f13e 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -6,7 +6,7 @@ * * * Auxiliary C functions for Interfaces.C.Streams * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -98,15 +98,6 @@ __gnat_is_regular_file_fd (int fd) int ret; GNAT_STRUCT_STAT statbuf; -#ifdef __EMX__ - /* Programs using screen I/O may need to reset the FPU after - initialization of screen-handling related DLL's, so force - DLL initialization by doing a null-write and then reset the FPU */ - - DosWrite (0, &ret, 0, &ret); - __gnat_init_float(); -#endif - ret = GNAT_FSTAT (fd, &statbuf); return (!ret && S_ISREG (statbuf.st_mode)); } @@ -166,9 +157,9 @@ __gnat_full_name (char *nam, char *buffer) else buffer[0] = '\0'; -#elif defined(__EMX__) || defined (__MINGW32__) - /* If this is a device file return it as is; under Windows NT and - OS/2 a device file end with ":". */ +#elif defined (__MINGW32__) + /* If this is a device file return it as is; + under Windows NT a device file ends with ":". */ if (nam[strlen (nam) - 1] == ':') strcpy (buffer, nam); else @@ -182,9 +173,6 @@ __gnat_full_name (char *nam, char *buffer) *p = '\\'; } -#elif defined (MSDOS) - _fixpath (nam, buffer); - #elif defined (sgi) || defined (__FreeBSD__) /* Use realpath function which resolves links and references to . and .. diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 8f08dcc81b8..b7f750d506f 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -76,7 +76,7 @@ package body Debug is -- dJ Output debugging trace info for JGNAT (Java VM version of GNAT) -- dK Kill all error messages -- dL Output trace information on elaboration checking - -- dM Asssume all variables are modified (no current values) + -- dM Assume all variables are modified (no current values) -- dN No file name information in exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages @@ -129,7 +129,7 @@ package body Debug is -- d.I SCIL generation mode -- d.J Parallel SCIL generation mode -- d.K - -- d.L + -- d.L Depend on back end for limited types in conditional expressions -- d.M -- d.N -- d.O Dump internal SCO tables @@ -141,9 +141,9 @@ package body Debug is -- d.U -- d.V -- d.W Print out debugging information for Walk_Library_Items - -- d.X - -- d.Y - -- d.Z + -- d.X Use Expression_With_Actions + -- d.Y Do not use Expression_With_Actions + -- d.Z Generate call-graph information -- d1 Error msgs have node numbers where possible -- d2 Eliminate error flags in verbose form error messages @@ -567,6 +567,11 @@ package body Debug is -- This means in particular not writing the same files under the -- same directory. + -- 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 + -- expressions correctly. + -- d.O Dump internal SCO tables. Before outputting the SCO information to -- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table) -- are dumped for debugging purposes. @@ -579,6 +584,24 @@ package body Debug is -- the order in which units are walked. This is primarily for SofCheck -- Inspector. + -- d.X By default, the compiler uses an elaborate rewriting framework for + -- short-circuited forms where the right hand condition generates + -- actions to be inserted. With the gcc backend, we now use the new + -- N_Expression_With_Actions node for this expansion, but we still use + -- the old method for other backends and in SCIL mode. This debug flag + -- forces use of the new N_Expression_With_Actions node in these other + -- cases and is intended for transitional use. + + -- d.Y Prevents the use of the N_Expression_With_Actions node even in the + -- case of the gcc back end. Provided as a back up in case the new + -- scheme has problems. + + -- d.Z This flag enables the frontend call-graph output associated with + -- dispatching calls. This is a temporary debug flag to be used during + -- development of this output. Once it works, it will always be output + -- (as part of the standard call-graph output) by default, and this + -- flag will be removed. + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 1fd68b8fcf7..f1145a1ac07 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -208,7 +208,6 @@ package body Einfo is -- Related_Expression Node24 -- Spec_PPC_List Node24 - -- Underlying_Record_View Node24 -- Interface_Alias Node25 -- Interfaces Elist25 @@ -228,6 +227,7 @@ package body Einfo is -- Wrapped_Entity Node27 -- Extra_Formals Node28 + -- Underlying_Record_View Node28 --------------------------------------------- -- Usage of Flags in Defining Entity Nodes -- @@ -455,9 +455,6 @@ package body Einfo is -- Is_Primitive_Wrapper Flag195 -- Was_Hidden Flag196 -- Is_Limited_Interface Flag197 - -- Is_Protected_Interface Flag198 - -- Is_Synchronized_Interface Flag199 - -- Is_Task_Interface Flag200 -- Has_Anon_Block_Suffix Flag201 -- Itype_Printed Flag202 @@ -511,6 +508,10 @@ package body Einfo is -- Is_Underlying_Record_View Flag246 -- OK_To_Rename Flag247 + -- (unused) Flag198 + -- (unused) Flag199 + -- (unused) Flag200 + ----------------------- -- Local subprograms -- ----------------------- @@ -559,9 +560,7 @@ package body Einfo is function Actual_Subtype (Id : E) return E is begin pragma Assert - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable - or else Ekind (Id) = E_Generic_In_Out_Parameter + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) or else Is_Formal (Id)); return Node17 (Id); end Actual_Subtype; @@ -571,6 +570,18 @@ package body Einfo is return Flag104 (Id); end Address_Taken; + function Aft_Value (Id : E) return U is + Result : Nat := 1; + Delta_Val : Ureal := Delta_Value (Id); + begin + while Delta_Val < Ureal_Tenth loop + Delta_Val := Delta_Val * Ureal_10; + Result := Result + 1; + end loop; + + return UI_From_Int (Result); + end Aft_Value; + function Alias (Id : E) return E is begin pragma Assert @@ -582,10 +593,10 @@ package body Einfo is begin pragma Assert (Is_Type (Id) or else Is_Formal (Id) - or else Ekind (Id) = E_Loop_Parameter - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Exception - or else Ekind (Id) = E_Variable); + or else Ekind_In (Id, E_Loop_Parameter, + E_Constant, + E_Exception, + E_Variable)); return Uint14 (Id); end Alignment; @@ -626,8 +637,7 @@ package body Einfo is function Body_Entity (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); return Node19 (Id); end Body_Entity; @@ -664,24 +674,19 @@ package body Einfo is function Cloned_Subtype (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else - Ekind (Id) = E_Class_Wide_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); return Node16 (Id); end Cloned_Subtype; function Component_Bit_Offset (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint11 (Id); end Component_Bit_Offset; function Component_Clause (Id : E) return N is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Node13 (Id); end Component_Clause; @@ -875,17 +880,14 @@ package body Einfo is function DT_Position (Id : E) return U is begin - pragma Assert - ((Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure) - and then Present (DTC_Entity (Id))); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Present (DTC_Entity (Id))); return Uint15 (Id); end DT_Position; function DTC_Entity (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Node16 (Id); end DTC_Entity; @@ -986,11 +988,12 @@ package body Einfo is function Equivalent_Type (Id : E) return E is begin pragma Assert - (Ekind (Id) = E_Class_Wide_Subtype or else - Ekind (Id) = E_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Access_Subprogram_Type or else - Ekind (Id) = E_Exception_Type); + (Ekind_In (Id, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type)); return Node18 (Id); end Equivalent_Type; @@ -1026,9 +1029,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); return Node28 (Id); end Extra_Formals; @@ -1074,15 +1077,13 @@ package body Einfo is function First_Optional_Parameter (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Node14 (Id); end First_Optional_Parameter; function First_Private_Entity (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Package - or else Ekind (Id) = E_Generic_Package + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) or else Ekind (Id) in Concurrent_Kind); return Node16 (Id); end First_Private_Entity; @@ -1278,8 +1279,7 @@ package body Einfo is function Has_Missing_Return (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function); + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); return Flag142 (Id); end Has_Missing_Return; @@ -1499,9 +1499,7 @@ package body Einfo is function Has_Up_Level_Access (Id : E) return B is begin pragma Assert - (Ekind (Id) = E_Variable - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Loop_Parameter); + (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); return Flag215 (Id); end Has_Up_Level_Access; @@ -1528,9 +1526,7 @@ package body Einfo is function Implemented_By_Entry (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Flag232 (Id); end Implemented_By_Entry; @@ -1615,8 +1611,7 @@ package body Einfo is function Is_Asynchronous (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Procedure or else Is_Type (Id)); + pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id)); return Flag81 (Id); end Is_Asynchronous; @@ -1632,8 +1627,7 @@ package body Einfo is function Is_Called (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function); + pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); return Flag102 (Id); end Is_Called; @@ -1744,10 +1738,7 @@ package body Einfo is function Is_For_Access_Subtype (Id : E) return B is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else - Ekind (Id) = E_Private_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); return Flag118 (Id); end Is_For_Access_Subtype; @@ -1937,15 +1928,13 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Generic_Function - or else Ekind (Id) = E_Generic_Procedure); + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); return Flag218 (Id); end Is_Primitive; function Is_Primitive_Wrapper (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Flag195 (Id); end Is_Primitive_Wrapper; @@ -1962,17 +1951,10 @@ package body Einfo is function Is_Private_Primitive (Id : E) return B is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); return Flag245 (Id); end Is_Private_Primitive; - function Is_Protected_Interface (Id : E) return B is - begin - pragma Assert (Is_Interface (Id)); - return Flag198 (Id); - end Is_Protected_Interface; - function Is_Public (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2032,12 +2014,6 @@ package body Einfo is return Flag28 (Id); end Is_Statically_Allocated; - function Is_Synchronized_Interface (Id : E) return B is - begin - pragma Assert (Is_Interface (Id)); - return Flag199 (Id); - end Is_Synchronized_Interface; - function Is_Tag (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2049,12 +2025,6 @@ package body Einfo is return Flag55 (Id); end Is_Tagged_Type; - function Is_Task_Interface (Id : E) return B is - begin - pragma Assert (Is_Interface (Id)); - return Flag200 (Id); - end Is_Task_Interface; - function Is_Thunk (Id : E) return B is begin pragma Assert (Is_Subprogram (Id)); @@ -2231,8 +2201,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Subprogram_Type - or else Ekind (Id) = E_Entry_Family); + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); return Flag22 (Id); end Needs_No_Actuals; @@ -2283,22 +2252,19 @@ package body Einfo is function Normalized_First_Bit (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint8 (Id); end Normalized_First_Bit; function Normalized_Position (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint14 (Id); end Normalized_Position; function Normalized_Position_Max (Id : E) return U is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); return Uint10 (Id); end Normalized_Position_Max; @@ -2317,18 +2283,14 @@ package body Einfo is function Optimize_Alignment_Space (Id : E) return B is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); return Flag241 (Id); end Optimize_Alignment_Space; function Optimize_Alignment_Time (Id : E) return B is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); return Flag242 (Id); end Optimize_Alignment_Time; @@ -2340,10 +2302,7 @@ package body Einfo is function Original_Record_Component (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Void - or else Ekind (Id) = E_Component - or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); return Node22 (Id); end Original_Record_Component; @@ -2359,10 +2318,7 @@ package body Einfo is function Package_Instantiation (Id : E) return N is begin - pragma Assert - (False - or else Ekind (Id) = E_Generic_Package - or else Ekind (Id) = E_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); return Node26 (Id); end Package_Instantiation; @@ -2398,8 +2354,7 @@ package body Einfo is function Prival_Link (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); return Node20 (Id); end Prival_Link; @@ -2429,10 +2384,8 @@ package body Einfo is function Protection_Object (Id : E) return E is begin - pragma Assert (Ekind (Id) = E_Entry - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert + (Ekind_In (Id, E_Entry, E_Entry_Family, E_Function, E_Procedure)); return Node23 (Id); end Protection_Object; @@ -2476,21 +2429,20 @@ package body Einfo is function Related_Expression (Id : E) return N is begin - pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + pragma Assert (Ekind (Id) in Type_Kind + or else Ekind_In (Id, E_Constant, E_Variable)); return Node24 (Id); end Related_Expression; function Related_Instance (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body); + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); return Node15 (Id); end Related_Instance; function Related_Type (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant); + pragma Assert (Ekind_In (Id, E_Component, E_Constant)); return Node26 (Id); end Related_Type; @@ -2576,8 +2528,7 @@ package body Einfo is function Shadow_Entities (Id : E) return S is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); return List14 (Id); end Shadow_Entities; @@ -2589,7 +2540,7 @@ package body Einfo is function Size_Check_Code (Id : E) return N is begin - pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); return Node19 (Id); end Size_Check_Code; @@ -2611,8 +2562,7 @@ package body Einfo is function Spec_Entity (Id : E) return E is begin - pragma Assert - (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); + pragma Assert (Ekind (Id) = E_Package_Body or else Is_Formal (Id)); return Node19 (Id); end Spec_Entity; @@ -2702,7 +2652,7 @@ package body Einfo is function Underlying_Record_View (Id : E) return E is begin - return Node24 (Id); + return Node28 (Id); end Underlying_Record_View; function Universal_Aliasing (Id : E) return B is @@ -2753,9 +2703,8 @@ package body Einfo is function Wrapped_Entity (Id : E) return E is begin - pragma Assert ((Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure) - and then Is_Primitive_Wrapper (Id)); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Id)); return Node27 (Id); end Wrapped_Entity; @@ -2963,8 +2912,7 @@ package body Einfo is function Is_Signed_Integer_Type (Id : E) return B is begin - return Ekind (Id) in - Signed_Integer_Kind; + return Ekind (Id) in Signed_Integer_Kind; end Is_Signed_Integer_Type; function Is_Subprogram (Id : E) return B is @@ -2986,6 +2934,12 @@ package body Einfo is -- Attribute Set Procedures -- ------------------------------ + -- Note: in many of these set procedures an "obvious" assertion is missing. + -- The reason for this is that in many cases, a field is set before the + -- Ekind field is set, so that the field is set when Ekind = E_Void. It + -- it is possible to add assertions that specifically include the E_Void + -- possibility, but in some cases, we just omit the assertions. + procedure Set_Accept_Address (Id : E; V : L) is begin Set_Elist21 (Id, V); @@ -3022,9 +2976,7 @@ package body Einfo is procedure Set_Actual_Subtype (Id : E; V : E) is begin pragma Assert - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable - or else Ekind (Id) = E_Generic_In_Out_Parameter + (Ekind_In (Id, E_Constant, E_Variable, E_Generic_In_Out_Parameter) or else Is_Formal (Id)); Set_Node17 (Id, V); end Set_Actual_Subtype; @@ -3044,11 +2996,11 @@ package body Einfo is procedure Set_Alignment (Id : E; V : U) is begin pragma Assert (Is_Type (Id) - or else Is_Formal (Id) - or else Ekind (Id) = E_Loop_Parameter - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Exception - or else Ekind (Id) = E_Variable); + or else Is_Formal (Id) + or else Ekind_In (Id, E_Loop_Parameter, + E_Constant, + E_Exception, + E_Variable)); Set_Uint14 (Id, V); end Set_Alignment; @@ -3066,8 +3018,7 @@ package body Einfo is procedure Set_Body_Entity (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); Set_Node19 (Id, V); end Set_Body_Entity; @@ -3075,8 +3026,8 @@ package body Einfo is begin pragma Assert (Ekind (Id) = E_Package - or else Is_Subprogram (Id) - or else Is_Generic_Unit (Id)); + or else Is_Subprogram (Id) + or else Is_Generic_Unit (Id)); Set_Flag40 (Id, V); end Set_Body_Needed_For_SAL; @@ -3104,23 +3055,19 @@ package body Einfo is procedure Set_Cloned_Subtype (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Class_Wide_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Class_Wide_Subtype)); Set_Node16 (Id, V); end Set_Cloned_Subtype; procedure Set_Component_Bit_Offset (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint11 (Id, V); end Set_Component_Bit_Offset; procedure Set_Component_Clause (Id : E; V : N) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Node13 (Id, V); end Set_Component_Clause; @@ -3225,9 +3172,7 @@ package body Einfo is procedure Set_Delay_Subprogram_Descriptors (Id : E; V : B := True) is begin pragma Assert - (Is_Subprogram (Id) - or else Ekind (Id) = E_Package - or else Ekind (Id) = E_Package_Body); + (Is_Subprogram (Id) or else Ekind_In (Id, E_Package, E_Package_Body)); Set_Flag50 (Id, V); end Set_Delay_Subprogram_Descriptors; @@ -3320,14 +3265,13 @@ package body Einfo is procedure Set_DT_Position (Id : E; V : U) is begin - pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Uint15 (Id, V); end Set_DT_Position; procedure Set_DTC_Entity (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Node16 (Id, V); end Set_DTC_Entity; @@ -3428,12 +3372,12 @@ package body Einfo is procedure Set_Equivalent_Type (Id : E; V : E) is begin pragma Assert - (Ekind (Id) = E_Class_Wide_Type or else - Ekind (Id) = E_Class_Wide_Subtype or else - Ekind (Id) = E_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Anonymous_Access_Protected_Subprogram_Type or else - Ekind (Id) = E_Access_Subprogram_Type or else - Ekind (Id) = E_Exception_Type); + (Ekind_In (Id, E_Class_Wide_Type, + E_Class_Wide_Subtype, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Access_Subprogram_Type, + E_Exception_Type)); Set_Node18 (Id, V); end Set_Equivalent_Type; @@ -3469,9 +3413,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); Set_Node28 (Id, V); end Set_Extra_Formals; @@ -3519,16 +3463,14 @@ package body Einfo is procedure Set_First_Optional_Parameter (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Node14 (Id, V); end Set_First_Optional_Parameter; procedure Set_First_Private_Entity (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Package - or else Ekind (Id) = E_Generic_Package - or else Ekind (Id) in Concurrent_Kind); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) + or else Ekind (Id) in Concurrent_Kind); Set_Node16 (Id, V); end Set_First_Private_Entity; @@ -3546,7 +3488,7 @@ package body Einfo is begin pragma Assert (Is_Type (Id) - or else Ekind (Id) = E_Package); + or else Ekind (Id) = E_Package); Set_Flag159 (Id, V); end Set_From_With_Type; @@ -3713,8 +3655,7 @@ package body Einfo is procedure Set_Has_Initial_Value (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Variable or else Ekind (Id) = E_Out_Parameter); + pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter)); Set_Flag219 (Id, V); end Set_Has_Initial_Value; @@ -3731,8 +3672,7 @@ package body Einfo is procedure Set_Has_Missing_Return (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Function or else Ekind (Id) = E_Generic_Function); + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); Set_Flag142 (Id, V); end Set_Has_Missing_Return; @@ -3743,10 +3683,7 @@ package body Einfo is procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Variable - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Loop_Parameter); + pragma Assert (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); Set_Flag215 (Id, V); end Set_Has_Up_Level_Access; @@ -3989,9 +3926,7 @@ package body Einfo is procedure Set_Implemented_By_Entry (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag232 (Id, V); end Set_Implemented_By_Entry; @@ -4006,8 +3941,7 @@ package body Einfo is pragma Assert (Is_Internal (Id) and then Is_Hidden (Id) - and then (Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Function)); + and then (Ekind_In (Id, E_Procedure, E_Function))); Set_Node25 (Id, V); end Set_Interface_Alias; @@ -4100,8 +4034,7 @@ package body Einfo is procedure Set_Is_Called (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function); + pragma Assert (Ekind_In (Id, E_Procedure, E_Function)); Set_Flag102 (Id, V); end Set_Is_Called; @@ -4224,10 +4157,7 @@ package body Einfo is procedure Set_Is_For_Access_Subtype (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Record_Subtype - or else - Ekind (Id) = E_Private_Subtype); + pragma Assert (Ekind_In (Id, E_Record_Subtype, E_Private_Subtype)); Set_Flag118 (Id, V); end Set_Is_For_Access_Subtype; @@ -4288,12 +4218,12 @@ package body Einfo is procedure Set_Is_Interface (Id : E; V : B := True) is begin pragma Assert - (Ekind (Id) = E_Record_Type - or else Ekind (Id) = E_Record_Subtype - or else Ekind (Id) = E_Record_Type_With_Private - or else Ekind (Id) = E_Record_Subtype_With_Private - or else Ekind (Id) = E_Class_Wide_Type - or else Ekind (Id) = E_Class_Wide_Subtype); + (Ekind_In (Id, E_Record_Type, + E_Record_Subtype, + E_Record_Type_With_Private, + E_Record_Subtype_With_Private, + E_Class_Wide_Type, + E_Class_Wide_Subtype)); Set_Flag186 (Id, V); end Set_Is_Interface; @@ -4428,15 +4358,13 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Generic_Function - or else Ekind (Id) = E_Generic_Procedure); + or else Ekind_In (Id, E_Generic_Function, E_Generic_Procedure)); Set_Flag218 (Id, V); end Set_Is_Primitive; procedure Set_Is_Primitive_Wrapper (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag195 (Id, V); end Set_Is_Primitive_Wrapper; @@ -4453,17 +4381,10 @@ package body Einfo is procedure Set_Is_Private_Primitive (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag245 (Id, V); end Set_Is_Private_Primitive; - procedure Set_Is_Protected_Interface (Id : E; V : B := True) is - begin - pragma Assert (Is_Interface (Id)); - Set_Flag198 (Id, V); - end Set_Is_Protected_Interface; - procedure Set_Is_Public (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -4521,25 +4442,17 @@ package body Einfo is procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is begin pragma Assert - (Ekind (Id) = E_Exception - or else Ekind (Id) = E_Variable - or else Ekind (Id) = E_Constant - or else Is_Type (Id) - or else Ekind (Id) = E_Void); + (Is_Type (Id) + or else Ekind_In (Id, E_Exception, + E_Variable, + E_Constant, + E_Void)); Set_Flag28 (Id, V); end Set_Is_Statically_Allocated; - procedure Set_Is_Synchronized_Interface (Id : E; V : B := True) is - begin - pragma Assert (Is_Interface (Id)); - Set_Flag199 (Id, V); - end Set_Is_Synchronized_Interface; - procedure Set_Is_Tag (Id : E; V : B := True) is begin - pragma Assert - (Ekind (Id) = E_Component - or else Ekind (Id) = E_Constant); + pragma Assert (Ekind_In (Id, E_Component, E_Constant)); Set_Flag78 (Id, V); end Set_Is_Tag; @@ -4548,12 +4461,6 @@ package body Einfo is Set_Flag55 (Id, V); end Set_Is_Tagged_Type; - procedure Set_Is_Task_Interface (Id : E; V : B := True) is - begin - pragma Assert (Is_Interface (Id)); - Set_Flag200 (Id, V); - end Set_Is_Task_Interface; - procedure Set_Is_Thunk (Id : E; V : B := True) is begin Set_Flag225 (Id, V); @@ -4728,8 +4635,7 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Subprogram_Type - or else Ekind (Id) = E_Entry_Family); + or else Ekind_In (Id, E_Subprogram_Type, E_Entry_Family)); Set_Flag22 (Id, V); end Set_Needs_No_Actuals; @@ -4752,9 +4658,7 @@ package body Einfo is procedure Set_No_Return (Id : E; V : B := True) is begin pragma Assert - (V = False - or else Ekind (Id) = E_Procedure - or else Ekind (Id) = E_Generic_Procedure); + (V = False or else Ekind_In (Id, E_Procedure, E_Generic_Procedure)); Set_Flag113 (Id, V); end Set_No_Return; @@ -4786,22 +4690,19 @@ package body Einfo is procedure Set_Normalized_First_Bit (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint8 (Id, V); end Set_Normalized_First_Bit; procedure Set_Normalized_Position (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint14 (Id, V); end Set_Normalized_Position; procedure Set_Normalized_Position_Max (Id : E; V : U) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); Set_Uint10 (Id, V); end Set_Normalized_Position_Max; @@ -4821,18 +4722,14 @@ package body Einfo is procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); Set_Flag241 (Id, V); end Set_Optimize_Alignment_Space; procedure Set_Optimize_Alignment_Time (Id : E; V : B := True) is begin pragma Assert - (Is_Type (Id) - or else Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + (Is_Type (Id) or else Ekind_In (Id, E_Constant, E_Variable)); Set_Flag242 (Id, V); end Set_Optimize_Alignment_Time; @@ -4844,10 +4741,7 @@ package body Einfo is procedure Set_Original_Record_Component (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Void - or else Ekind (Id) = E_Component - or else Ekind (Id) = E_Discriminant); + pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant)); Set_Node22 (Id, V); end Set_Original_Record_Component; @@ -4863,10 +4757,7 @@ package body Einfo is procedure Set_Package_Instantiation (Id : E; V : N) is begin - pragma Assert - (Ekind (Id) = E_Void - or else Ekind (Id) = E_Generic_Package - or else Ekind (Id) = E_Package); + pragma Assert (Ekind_In (Id, E_Void, E_Generic_Package, E_Package)); Set_Node26 (Id, V); end Set_Package_Instantiation; @@ -4902,8 +4793,7 @@ package body Einfo is procedure Set_Prival_Link (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); Set_Node20 (Id, V); end Set_Prival_Link; @@ -4933,10 +4823,10 @@ package body Einfo is procedure Set_Protection_Object (Id : E; V : E) is begin - pragma Assert (Ekind (Id) = E_Entry - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure)); Set_Node23 (Id, V); end Set_Protection_Object; @@ -4980,20 +4870,20 @@ package body Einfo is procedure Set_Related_Expression (Id : E; V : N) is begin + pragma Assert (Ekind (Id) in Type_Kind + or else Ekind_In (Id, E_Constant, E_Variable, E_Void)); Set_Node24 (Id, V); end Set_Related_Expression; procedure Set_Related_Instance (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body); + pragma Assert (Ekind_In (Id, E_Package, E_Package_Body)); Set_Node15 (Id, V); end Set_Related_Instance; procedure Set_Related_Type (Id : E; V : E) is begin - pragma Assert - (Ekind (Id) = E_Component or else Ekind (Id) = E_Constant); + pragma Assert (Ekind_In (Id, E_Component, E_Constant)); Set_Node26 (Id, V); end Set_Related_Type; @@ -5081,8 +4971,7 @@ package body Einfo is procedure Set_Shadow_Entities (Id : E; V : S) is begin - pragma Assert - (Ekind (Id) = E_Package or else Ekind (Id) = E_Generic_Package); + pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package)); Set_List14 (Id, V); end Set_Shadow_Entities; @@ -5094,7 +4983,7 @@ package body Einfo is procedure Set_Size_Check_Code (Id : E; V : N) is begin - pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable); + pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); Set_Node19 (Id, V); end Set_Size_Check_Code; @@ -5211,7 +5100,7 @@ package body Einfo is procedure Set_Underlying_Record_View (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Record_Type); - Set_Node24 (Id, V); + Set_Node28 (Id, V); end Set_Underlying_Record_View; procedure Set_Universal_Aliasing (Id : E; V : B := True) is @@ -5268,9 +5157,8 @@ package body Einfo is procedure Set_Wrapped_Entity (Id : E; V : E) is begin - pragma Assert ((Ekind (Id) = E_Function - or else Ekind (Id) = E_Procedure) - and then Is_Primitive_Wrapper (Id)); + pragma Assert (Ekind_In (Id, E_Function, E_Procedure) + and then Is_Primitive_Wrapper (Id)); Set_Node27 (Id, V); end Set_Wrapped_Entity; @@ -5465,7 +5353,8 @@ package body Einfo is function Known_Static_Esize (E : Entity_Id) return B is begin - return Uint12 (E) > Uint_0; + return Uint12 (E) > Uint_0 + and then not Is_Generic_Type (E); end Known_Static_Esize; function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is @@ -5488,9 +5377,10 @@ package body Einfo is function Known_Static_RM_Size (E : Entity_Id) return B is begin - return Uint13 (E) > Uint_0 - or else Is_Discrete_Type (E) - or else Is_Fixed_Point_Type (E); + return (Uint13 (E) > Uint_0 + or else Is_Discrete_Type (E) + or else Is_Fixed_Point_Type (E)) + and then not Is_Generic_Type (E); end Known_Static_RM_Size; function Unknown_Alignment (E : Entity_Id) return B is @@ -5765,9 +5655,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -5793,9 +5683,9 @@ package body Einfo is begin pragma Assert (Is_Overloadable (Id) - or else Ekind (Id) = E_Entry_Family - or else Ekind (Id) = E_Subprogram_Body - or else Ekind (Id) = E_Subprogram_Type); + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); if Ekind (Id) = E_Enumeration_Literal then return Empty; @@ -5842,9 +5732,7 @@ package body Einfo is function Get_Full_View (T : Entity_Id) return Entity_Id is begin - if Ekind (T) = E_Incomplete_Type - and then Present (Full_View (T)) - then + if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then return Full_View (T); elsif Is_Class_Wide_Type (T) @@ -5858,6 +5746,26 @@ package body Einfo is end if; end Get_Full_View; + -------------------------------------- + -- Get_Record_Representation_Clause -- + -------------------------------------- + + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is + N : Node_Id; + + begin + N := First_Rep_Item (E); + while Present (N) loop + if Nkind (N) = N_Record_Representation_Clause then + return N; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Record_Representation_Clause; + -------------------- -- Get_Rep_Pragma -- -------------------- @@ -5942,7 +5850,13 @@ package body Einfo is function Has_Foreign_Convention (Id : E) return B is begin - return Convention (Id) in Foreign_Convention; + -- While regular Intrinsics such as the Standard operators fit in the + -- "Ada" convention, those with an Interface_Name materialize GCC + -- builtin imports for which Ada special treatments shouldn't apply. + + return Convention (Id) in Foreign_Convention + or else (Convention (Id) = Convention_Intrinsic + and then Present (Interface_Name (Id))); end Has_Foreign_Convention; --------------------------- @@ -6098,10 +6012,8 @@ package body Einfo is function Is_Discriminal (Id : E) return B is begin - return - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_In_Parameter) - and then Present (Discriminal_Link (Id)); + return (Ekind_In (Id, E_Constant, E_In_Parameter) + and then Present (Discriminal_Link (Id))); end Is_Discriminal; ---------------------- @@ -6169,10 +6081,8 @@ package body Einfo is function Is_Prival (Id : E) return B is begin - return - (Ekind (Id) = E_Constant - or else Ekind (Id) = E_Variable) - and then Present (Prival_Link (Id)); + return (Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id))); end Is_Prival; ---------------------------- @@ -6185,6 +6095,22 @@ package body Einfo is and then Is_Protected_Type (Scope (Id)); end Is_Protected_Component; + ---------------------------- + -- Is_Protected_Interface -- + ---------------------------- + + function Is_Protected_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + begin + if not Is_Interface (Typ) then + return False; + elsif Is_Class_Wide_Type (Typ) then + return Is_Protected_Interface (Etype (Typ)); + else + return Protected_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Protected_Interface; + ------------------------------ -- Is_Protected_Record_Type -- ------------------------------ @@ -6227,10 +6153,47 @@ package body Einfo is begin return Ekind (Id) in String_Kind or else (Is_Array_Type (Id) - and then Number_Dimensions (Id) = 1 - and then Is_Character_Type (Component_Type (Id))); + and then Number_Dimensions (Id) = 1 + and then Is_Character_Type (Component_Type (Id))); end Is_String_Type; + ------------------------------- + -- Is_Synchronized_Interface -- + ------------------------------- + + function Is_Synchronized_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + + begin + if not Is_Interface (Typ) then + return False; + + elsif Is_Class_Wide_Type (Typ) then + return Is_Synchronized_Interface (Etype (Typ)); + + else + return Protected_Present (Type_Definition (Parent (Typ))) + or else Synchronized_Present (Type_Definition (Parent (Typ))) + or else Task_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Synchronized_Interface; + + ----------------------- + -- Is_Task_Interface -- + ----------------------- + + function Is_Task_Interface (Id : E) return B is + Typ : constant Entity_Id := Base_Type (Id); + begin + if not Is_Interface (Typ) then + return False; + elsif Is_Class_Wide_Type (Typ) then + return Is_Task_Interface (Etype (Typ)); + else + return Task_Present (Type_Definition (Parent (Typ))); + end if; + end Is_Task_Interface; + ------------------------- -- Is_Task_Record_Type -- ------------------------- @@ -6249,9 +6212,39 @@ package body Einfo is function Is_Wrapper_Package (Id : E) return B is begin return (Ekind (Id) = E_Package - and then Present (Related_Instance (Id))); + and then Present (Related_Instance (Id))); end Is_Wrapper_Package; + ----------------- + -- Last_Formal -- + ----------------- + + function Last_Formal (Id : E) return E is + Formal : E; + + begin + pragma Assert + (Is_Overloadable (Id) + or else Ekind_In (Id, E_Entry_Family, + E_Subprogram_Body, + E_Subprogram_Type)); + + if Ekind (Id) = E_Enumeration_Literal then + return Empty; + + else + Formal := First_Formal (Id); + + if Present (Formal) then + while Present (Next_Formal (Formal)) loop + Formal := Next_Formal (Formal); + end loop; + end if; + + return Formal; + end if; + end Last_Formal; + -------------------- -- Next_Component -- -------------------- @@ -6279,9 +6272,7 @@ package body Einfo is begin Comp_Id := Next_Entity (Id); while Present (Comp_Id) loop - exit when Ekind (Comp_Id) = E_Component - or else - Ekind (Comp_Id) = E_Discriminant; + exit when Ekind_In (Comp_Id, E_Component, E_Discriminant); Comp_Id := Next_Entity (Comp_Id); end loop; @@ -6318,7 +6309,7 @@ package body Einfo is D := Next_Entity (D); if No (D) or else (Ekind (D) /= E_Discriminant - and then not Is_Itype (D)) + and then not Is_Itype (D)) then return Empty; end if; @@ -7002,7 +6993,6 @@ package body Einfo is W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); W ("Is_Private_Primitive", Flag245 (Id)); - W ("Is_Protected_Interface", Flag198 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Pure_Unit_Access_Type", Flag189 (Id)); @@ -7013,11 +7003,9 @@ package body Einfo is W ("Is_Renaming_Of_Object", Flag112 (Id)); W ("Is_Return_Object", Flag209 (Id)); W ("Is_Shared_Passive", Flag60 (Id)); - W ("Is_Synchronized_Interface", Flag199 (Id)); W ("Is_Statically_Allocated", Flag28 (Id)); W ("Is_Tag", Flag78 (Id)); W ("Is_Tagged_Type", Flag55 (Id)); - W ("Is_Task_Interface", Flag200 (Id)); W ("Is_Thunk", Flag225 (Id)); W ("Is_Trivial_Subprogram", Flag235 (Id)); W ("Is_True_Constant", Flag163 (Id)); @@ -7976,14 +7964,11 @@ package body Einfo is when Subprogram_Kind => Write_Str ("Spec_PPC_List"); - when E_Record_Type => - Write_Str ("Underlying record view"); - - when E_Variable | E_Constant => - Write_Str ("Related expression"); + when E_Variable | E_Constant | Type_Kind => + Write_Str ("Related_Expression"); when others => - Write_Str ("???"); + Write_Str ("Field24???"); end case; end Write_Field24_Name; @@ -8087,6 +8072,9 @@ package body Einfo is when E_Procedure | E_Function | E_Entry => Write_Str ("Extra_Formals"); + when E_Record_Type => + Write_Str ("Underlying_Record_View"); + when others => Write_Str ("Field28??"); end case; @@ -8105,9 +8093,7 @@ package body Einfo is begin N := Next_Entity (N); while Present (N) loop - exit when Ekind (N) = E_Component - or else - Ekind (N) = E_Discriminant; + exit when Ekind_In (N, E_Component, E_Discriminant); N := Next_Entity (N); end loop; end Proc_Next_Component_Or_Discriminant; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d9ff8c0a24d..a3bff056113 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -350,6 +350,10 @@ package Einfo is -- make sure that the address can be meaningfully taken, and also in -- the case of subprograms to control output of certain warnings. +-- Aft_Value (synthesized) +-- Applies to fixed and decimal types. Computes a universal integer +-- that holds value of the Aft attribute for the type. + -- Alias (Node18) -- Present in overloaded entities (literals, subprograms, entries) and -- subprograms that cover a primitive operation of an abstract interface @@ -2477,7 +2481,7 @@ package Einfo is -- Applicable to all entities, true if the entity denotes a private -- component of a protected type. --- Is_Protected_Interface (Flag198) +-- Is_Protected_Interface (synthesized) -- Present in types that are interfaces. True if interface is declared -- protected, or is derived from protected interfaces. @@ -2584,7 +2588,7 @@ package Einfo is -- Applies to all entities, true for function, procedure and operator -- entities. --- Is_Synchronized_Interface (Flag199) +-- Is_Synchronized_Interface (synthesized) -- Present in types that are interfaces. True if interface is declared -- synchronized, task, or protected, or is derived from a synchronized -- interface. @@ -2598,7 +2602,7 @@ package Einfo is -- Is_Tagged_Type (Flag55) -- Present in all entities. Set for an entity for a tagged type. --- Is_Task_Interface (Flag200) +-- Is_Task_Interface (synthesized) -- Present in types that are interfaces. True if interface is declared as -- a task interface, or if it is derived from task interfaces. @@ -2752,6 +2756,13 @@ package Einfo is -- Points to the last entry in the list of associated entities chained -- through the Next_Entity field. Empty if no entities are chained. +-- Last_Formal (synthesized) +-- Applies to subprograms and subprogram types, and also in entries +-- and entry families. Returns last formal of the subprogram or entry. +-- The formals are the first entities declared in a subprogram or in +-- a subprogram type (the designated type of an Access_To_Subprogram +-- definition) or in an entry. + -- Limited_View (Node23) -- Present in non-generic package entities that are not instances. Bona -- fide package with the limited-view list through the first_entity and @@ -3141,7 +3152,9 @@ package Einfo is -- types. Points to an element list of entities for primitive operations -- for the tagged type. Not present (and not set) in untagged types (it -- is an error to reference the primitive operations field of a type --- that is not tagged). +-- that is not tagged). In order to fulfill the C++ ABI, entities of +-- primitives that come from source must be stored in this list following +-- their order of occurrence in the sources. -- Prival (Node17) -- Present in private components of protected types. Refers to the entity @@ -3244,9 +3257,13 @@ package Einfo is -- only for type-related error messages. -- Related_Expression (Node24) --- Present in variables generated internally. Denotes the source --- expression whose elaboration created the variable declaration. --- Used for clearer messages from CodePeer. +-- Present in variables and types. Set only for internally generated +-- entities, where it may be used to denote the source expression whose +-- elaboration created the variable declaration. If set, it is used +-- for generating clearer messages from CodePeer. +-- +-- Shouldn't it also be used for the same purpose in errout? It seems +-- odd to have two mechanisms here??? -- Related_Instance (Node15) -- Present in the wrapper packages created for subprogram instances. @@ -3539,12 +3556,13 @@ package Einfo is -- value may be passed around, and if used, may clobber a local variable. -- Task_Body_Procedure (Node25) --- Present in task types and subtypes. Points to the entity for --- the task body procedure (as further described in Exp_Ch9, task --- bodies are expanded into procedures). A convenient function to --- retrieve this field is Sem_Util.Get_Task_Body_Procedure. --- The last sentence is odd ??? Why not have Task_Body_Procedure --- go to the Underlying_Type of the Root_Type??? +-- Present in task types and subtypes. Points to the entity for the task +-- task body procedure (as further described in Exp_Ch9, task bodies are +-- expanded into procedures). A convenient function to retrieve this +-- field is Sem_Util.Get_Task_Body_Procedure. +-- +-- The last sentence is odd??? Why not have Task_Body_Procedure go to the +-- Underlying_Type of the Root_Type??? -- Treat_As_Volatile (Flag41) -- Present in all type entities, and also in constants, components and @@ -3591,7 +3609,7 @@ package Einfo is -- private completion. If Td is already constrained, then its full view -- can serve directly as the full view of T. --- Underlying_Record_View (Node24) +-- Underlying_Record_View (Node28) -- Present in record types. Set for record types that are extensions of -- types with unknown discriminants, and also set for internally built -- underlying record views to reference its original record type. Record @@ -4599,6 +4617,7 @@ package Einfo is -- Esize (Uint12) -- RM_Size (Uint13) -- Alignment (Uint14) + -- Related_Expression (Node24) -- Depends_On_Private (Flag14) -- Discard_Names (Flag88) @@ -4635,10 +4654,7 @@ package Einfo is -- Is_Eliminated (Flag124) -- Is_Frozen (Flag4) -- Is_Generic_Actual_Type (Flag94) - -- Is_Protected_Interface (Flag198) -- Is_RACW_Stub_Type (Flag244) - -- Is_Synchronized_Interface (Flag199) - -- Is_Task_Interface (Flag200) -- Is_Non_Static_Subtype (Flag109) -- Is_Packed (Flag51) (base type only) -- Is_Private_Composite (Flag107) @@ -4829,6 +4845,7 @@ package Einfo is -- Small_Value (Ureal21) -- Has_Machine_Radix_Clause (Flag83) -- Machine_Radix_10 (Flag84) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -4873,9 +4890,10 @@ package Einfo is -- Sec_Stack_Needed_For_Return (Flag167) -- Uses_Sec_Stack (Flag95) -- Address_Clause (synth) + -- Entry_Index_Type (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) - -- Entry_Index_Type (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- Scope_Depth (synth) @@ -4994,6 +5012,7 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- Scope_Depth (synth) @@ -5111,6 +5130,7 @@ package Einfo is -- Scalar_Range (Node20) -- Small_Value (Ureal21) -- Has_Small_Clause (Flag67) + -- Aft_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5209,7 +5229,7 @@ package Einfo is -- Spec_PPC_List (Node24) -- Interface_Alias (Node25) -- Static_Initialization (Node26) (init_proc only) - -- Overridden_Operation (Node26) + -- Overridden_Operation (Node26) (never for init proc) -- Wrapped_Entity (Node27) (non-generic case only) -- Extra_Formals (Node28) -- Body_Needed_For_SAL (Flag40) @@ -5252,6 +5272,7 @@ package Einfo is -- Address_Clause (synth) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- E_Protected_Body @@ -5290,8 +5311,8 @@ package Einfo is -- Discriminant_Constraint (Elist21) -- Corresponding_Remote_Type (Node22) -- Stored_Constraint (Elist23) - -- Underlying_Record_View (Node24) (base type only) -- Interfaces (Elist25) + -- Underlying_Record_View (Node28) (base type only) -- Component_Alignment (special) (base type only) -- C_Pass_By_Copy (Flag125) (base type only) -- Has_Dispatch_Table (Flag220) (base tagged type only) @@ -5376,6 +5397,7 @@ package Einfo is -- Directly_Designated_Type (Node20) -- First_Formal (synth) -- First_Formal_With_Extras (synth) + -- Last_Formal (synth) -- Number_Formals (synth) -- (plus type attributes) @@ -5909,7 +5931,6 @@ package Einfo is function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; function Is_Private_Primitive (Id : E) return B; - function Is_Protected_Interface (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Pure_Unit_Access_Type (Id : E) return B; @@ -5921,10 +5942,8 @@ package Einfo is function Is_Return_Object (Id : E) return B; function Is_Shared_Passive (Id : E) return B; function Is_Statically_Allocated (Id : E) return B; - function Is_Synchronized_Interface (Id : E) return B; function Is_Tag (Id : E) return B; function Is_Tagged_Type (Id : E) return B; - function Is_Task_Interface (Id : E) return B; function Is_Thunk (Id : E) return B; function Is_Trivial_Subprogram (Id : E) return B; function Is_True_Constant (Id : E) return B; @@ -6113,6 +6132,7 @@ package Einfo is -- so they do not correspond to defined fields in the entity itself. function Address_Clause (Id : E) return N; + function Aft_Value (Id : E) return U; function Alignment_Clause (Id : E) return N; function Base_Type (Id : E) return E; function Declaration_Node (Id : E) return N; @@ -6134,11 +6154,15 @@ package Einfo is function Is_Package_Or_Generic_Package (Id : E) return B; function Is_Prival (Id : E) return B; function Is_Protected_Component (Id : E) return B; + function Is_Protected_Interface (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B; function Is_Standard_Character_Type (Id : E) return B; function Is_String_Type (Id : E) return B; + function Is_Synchronized_Interface (Id : E) return B; + function Is_Task_Interface (Id : E) return B; function Is_Task_Record_Type (Id : E) return B; function Is_Wrapper_Package (Id : E) return B; + function Last_Formal (Id : E) return E; function Next_Component (Id : E) return E; function Next_Component_Or_Discriminant (Id : E) return E; function Next_Discriminant (Id : E) return E; @@ -6188,6 +6212,13 @@ package Einfo is -- value is always known static for discrete types (and no other types can -- have an RM_Size value of zero). + -- In two cases, Known_Static_Esize and Known_Static_RM_Size, there is one + -- more consideration, which is that we always return False for generic + -- types. Within a template, the size can look known, because of the fake + -- size values we put in template types, but they are not really known and + -- anyone testing if they are known within the template should get False as + -- a result to prevent incorrect assumptions. + function Known_Alignment (E : Entity_Id) return B; function Known_Component_Bit_Offset (E : Entity_Id) return B; function Known_Component_Size (E : Entity_Id) return B; @@ -6465,7 +6496,6 @@ package Einfo is procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); procedure Set_Is_Private_Primitive (Id : E; V : B := True); - procedure Set_Is_Protected_Interface (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True); @@ -6477,10 +6507,8 @@ package Einfo is procedure Set_Is_Return_Object (Id : E; V : B := True); procedure Set_Is_Shared_Passive (Id : E; V : B := True); procedure Set_Is_Statically_Allocated (Id : E; V : B := True); - procedure Set_Is_Synchronized_Interface (Id : E; V : B := True); procedure Set_Is_Tag (Id : E; V : B := True); procedure Set_Is_Tagged_Type (Id : E; V : B := True); - procedure Set_Is_Task_Interface (Id : E; V : B := True); procedure Set_Is_Thunk (Id : E; V : B := True); procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True); procedure Set_Is_True_Constant (Id : E; V : B := True); @@ -6767,6 +6795,11 @@ package Einfo is -- value returned is the N_Attribute_Definition_Clause node, otherwise -- Empty is returned. + function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entyt E, for a record + -- representation clause, and if found, returns it. Returns Empty + -- if no such clause is found. + function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id; -- Searches the Rep_Item chain for the given entity E, for an instance -- a representation pragma with the given name Nam. If found then the @@ -6803,9 +6836,9 @@ package Einfo is -- Add an entity to the list of entities declared in the scope V function Get_Full_View (T : Entity_Id) return Entity_Id; - -- If T is an incomplete type and the full declaration has been - -- seen, or is the name of a class_wide type whose root is incomplete. - -- return the corresponding full declaration. + -- If T is an incomplete type and the full declaration has been seen, or + -- is the name of a class_wide type whose root is incomplete, return the + -- corresponding full declaration, else return T itself. function Is_Entity_Name (N : Node_Id) return Boolean; -- Test if the node N is the name of an entity (i.e. is an identifier, @@ -7152,7 +7185,6 @@ package Einfo is pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Primitive); pragma Inline (Is_Private_Type); - pragma Inline (Is_Protected_Interface); pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); @@ -7170,10 +7202,8 @@ package Einfo is pragma Inline (Is_Signed_Integer_Type); pragma Inline (Is_Statically_Allocated); pragma Inline (Is_Subprogram); - pragma Inline (Is_Synchronized_Interface); pragma Inline (Is_Tag); pragma Inline (Is_Tagged_Type); - pragma Inline (Is_Task_Interface); pragma Inline (Is_True_Constant); pragma Inline (Is_Task_Type); pragma Inline (Is_Thunk); @@ -7552,7 +7582,6 @@ package Einfo is pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); pragma Inline (Set_Is_Private_Primitive); - pragma Inline (Set_Is_Protected_Interface); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Pure_Unit_Access_Type); @@ -7564,10 +7593,8 @@ package Einfo is pragma Inline (Set_Is_Return_Object); pragma Inline (Set_Is_Shared_Passive); pragma Inline (Set_Is_Statically_Allocated); - pragma Inline (Set_Is_Synchronized_Interface); pragma Inline (Set_Is_Tag); pragma Inline (Set_Is_Tagged_Type); - pragma Inline (Set_Is_Task_Interface); pragma Inline (Set_Is_Thunk); pragma Inline (Set_Is_Trivial_Subprogram); pragma Inline (Set_Is_True_Constant); diff --git a/gcc/ada/env.c b/gcc/ada/env.c index c8b49ebe122..c53678ab831 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2005-2009, Free Software Foundation, Inc. * + * Copyright (C) 2005-2010, 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- * @@ -107,9 +107,7 @@ typedef struct _ile3 void __gnat_setenv (char *name, char *value) { -#ifdef MSDOS - -#elif defined (VMS) +#if defined (VMS) struct descriptor_s name_desc; /* Put in JOB table for now, so that the project stuff at least works. */ struct descriptor_s table_desc = {7, 0, "LNM$JOB"}; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 651b43d1122..e307ce7e44d 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,6 +43,7 @@ with Opt; use Opt; with Nlists; use Nlists; with Output; use Output; with Scans; use Scans; +with Sem_Aux; use Sem_Aux; with Sinput; use Sinput; with Sinfo; use Sinfo; with Snames; use Snames; @@ -176,25 +177,24 @@ package body Errout is -- If the message should be generated (the normal case) False is returned. procedure Unwind_Internal_Type (Ent : in out Entity_Id); - -- This procedure is given an entity id for an internal type, i.e. - -- a type with an internal name. It unwinds the type to try to get - -- to something reasonably printable, generating prefixes like - -- "subtype of", "access to", etc along the way in the buffer. The - -- value in Ent on return is the final name to be printed. Hopefully - -- this is not an internal name, but in some internal name cases, it - -- is an internal name, and has to be printed anyway (although in this - -- case the message has been killed if possible). The global variable - -- Class_Flag is set to True if the resulting entity should have - -- 'Class appended to its name (see Add_Class procedure), and is - -- otherwise unchanged. + -- This procedure is given an entity id for an internal type, i.e. a type + -- with an internal name. It unwinds the type to try to get to something + -- reasonably printable, generating prefixes like "subtype of", "access + -- to", etc along the way in the buffer. The value in Ent on return is the + -- final name to be printed. Hopefully this is not an internal name, but in + -- some internal name cases, it is an internal name, and has to be printed + -- anyway (although in this case the message has been killed if possible). + -- The global variable Class_Flag is set to True if the resulting entity + -- should have 'Class appended to its name (see Add_Class procedure), and + -- is otherwise unchanged. procedure VMS_Convert; - -- This procedure has no effect if called when the host is not OpenVMS. - -- If the host is indeed OpenVMS, then the error message stored in - -- Msg_Buffer is scanned for appearances of switch names which need - -- converting to corresponding VMS qualifier names. See Gnames/Vnames - -- table in Errout spec for precise definition of the conversion that - -- is performed by this routine in OpenVMS mode. + -- This procedure has no effect if called when the host is not OpenVMS. If + -- the host is indeed OpenVMS, then the error message stored in Msg_Buffer + -- is scanned for appearances of switch names which need converting to + -- corresponding VMS qualifier names. See Gnames/Vnames table in Errout + -- spec for precise definition of the conversion that is performed by this + -- routine in OpenVMS mode. ----------------------- -- Change_Error_Text -- @@ -242,10 +242,10 @@ package body Errout is --------------- -- Error_Msg posts a flag at the given location, except that if the - -- Flag_Location points within a generic template and corresponds - -- to an instantiation of this generic template, then the actual - -- message will be posted on the generic instantiation, along with - -- additional messages referencing the generic declaration. + -- Flag_Location points within a generic template and corresponds to an + -- instantiation of this generic template, then the actual message will be + -- posted on the generic instantiation, along with additional messages + -- referencing the generic declaration. procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is Sindex : Source_File_Index; @@ -256,8 +256,8 @@ package body Errout is -- template in instantiation case, otherwise unchanged). begin - -- It is a fatal error to issue an error message when scanning from - -- the internal source buffer (see Sinput for further documentation) + -- It is a fatal error to issue an error message when scanning from the + -- internal source buffer (see Sinput for further documentation) pragma Assert (Sinput.Source /= Internal_Source_Ptr); @@ -267,8 +267,8 @@ package body Errout is return; end if; - -- If we already have messages, and we are trying to place a message - -- at No_Location or in package Standard, then just ignore the attempt + -- If we already have messages, and we are trying to place a message at + -- No_Location or in package Standard, then just ignore the attempt -- since we assume that what is happening is some cascaded junk. Note -- that this is safe in the sense that proceeding will surely bomb. @@ -284,24 +284,23 @@ package body Errout is Test_Style_Warning_Serious_Msg (Msg); Orig_Loc := Original_Location (Flag_Location); - -- If the current location is in an instantiation, the issue arises - -- of whether to post the message on the template or the instantiation. + -- If the current location is in an instantiation, the issue arises of + -- whether to post the message on the template or the instantiation. - -- The way we decide is to see if we have posted the same message - -- on the template when we compiled the template (the template is - -- always compiled before any instantiations). For this purpose, - -- we use a separate table of messages. The reason we do this is - -- twofold: + -- The way we decide is to see if we have posted the same message on + -- the template when we compiled the template (the template is always + -- compiled before any instantiations). For this purpose, we use a + -- separate table of messages. The reason we do this is twofold: -- First, the messages can get changed by various processing -- including the insertion of tokens etc, making it hard to -- do the comparison. - -- Second, we will suppress a warning on a template if it is - -- not in the current extended source unit. That's reasonable - -- and means we don't want the warning on the instantiation - -- here either, but it does mean that the main error table - -- would not in any case include the message. + -- Second, we will suppress a warning on a template if it is not in + -- the current extended source unit. That's reasonable and means we + -- don't want the warning on the instantiation here either, but it + -- does mean that the main error table would not in any case include + -- the message. if Flag_Location = Orig_Loc then Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location)); @@ -310,8 +309,8 @@ package body Errout is -- Here we have an instance message else - -- Delete if debug flag off, and this message duplicates a - -- message already posted on the corresponding template + -- Delete if debug flag off, and this message duplicates a message + -- already posted on the corresponding template if not Debug_Flag_GG then for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop @@ -373,9 +372,9 @@ package body Errout is -- instantiation error message can be repeated, pointing to each -- of the relevant instantiations. - -- Note: the instantiation mechanism is also shared for inlining - -- of subprogram bodies when front end inlining is done. In this - -- case the messages have the form: + -- Note: the instantiation mechanism is also shared for inlining of + -- subprogram bodies when front end inlining is done. In this case the + -- messages have the form: -- in inlined body at ... -- original error message @@ -385,9 +384,8 @@ package body Errout is -- warning: in inlined body at -- warning: original warning message - -- OK, this is the case where we have an instantiation error, and - -- we need to generate the error on the instantiation, rather than - -- on the template. + -- OK, here we have an instantiation error, and we need to generate the + -- error on the instantiation, rather than on the template. declare Actual_Error_Loc : Source_Ptr; @@ -396,9 +394,9 @@ package body Errout is -- location where all error messages will actually be posted. Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc; - -- Save possible location set for caller's message. We need to - -- use Error_Msg_Sloc for the location of the instantiation error - -- but we have to preserve a possible original value. + -- Save possible location set for caller's message. We need to use + -- Error_Msg_Sloc for the location of the instantiation error but we + -- have to preserve a possible original value. X : Source_File_Index; @@ -417,10 +415,9 @@ package body Errout is exit when Instantiation (X) = No_Location; end loop; - -- Since we are generating the messages at the instantiation - -- point in any case, we do not want the references to the - -- bad lines in the instance to be annotated with the location - -- of the instantiation. + -- Since we are generating the messages at the instantiation point in + -- any case, we do not want the references to the bad lines in the + -- instance to be annotated with the location of the instantiation. Suppress_Instance_Location := True; Msg_Cont_Status := False; @@ -679,10 +676,10 @@ package body Errout is Expander_Active := False; end if; - -- Set the fatal error flag in the unit table unless we are - -- in Try_Semantics mode. This stops the semantics from being - -- performed if we find a serious error. This is skipped if we - -- are currently dealing with the configuration pragma file. + -- Set the fatal error flag in the unit table unless we are in + -- Try_Semantics mode. This stops the semantics from being performed + -- if we find a serious error. This is skipped if we are currently + -- dealing with the configuration pragma file. if not Try_Semantics and then Current_Source_Unit /= No_Unit then Set_Fatal_Error (Get_Source_Unit (Sptr)); @@ -722,10 +719,10 @@ package body Errout is return; end if; - -- Return without doing anything if message is killed and this - -- is not the first error message. The philosophy is that if we - -- get a weird error message and we already have had a message, - -- then we hope the weird message is a junk cascaded message + -- Return without doing anything if message is killed and this is not + -- the first error message. The philosophy is that if we get a weird + -- error message and we already have had a message, then we hope the + -- weird message is a junk cascaded message if Kill_Message and then not All_Errors_Mode @@ -749,15 +746,15 @@ package body Errout is return; end if; - -- If the flag location is in the main extended source unit - -- then for sure we want the warning since it definitely belongs + -- If the flag location is in the main extended source unit then for + -- sure we want the warning since it definitely belongs if In_Extended_Main_Source_Unit (Sptr) then null; - -- If the flag location is not in the main extended source unit, - -- then we want to eliminate the warning, unless it is in the - -- extended main code unit and we want warnings on the instance. + -- If the flag location is not in the main extended source unit, then + -- we want to eliminate the warning, unless it is in the extended + -- main code unit and we want warnings on the instance. elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then null; @@ -884,6 +881,7 @@ package body Errout is Errors.Append ((Text => new String'(Msg_Buffer (1 .. Msglen)), Next => No_Error_Msg, + Prev => No_Error_Msg, Sptr => Sptr, Optr => Optr, Sfile => Get_Source_File_Index (Sptr), @@ -1217,7 +1215,34 @@ package body Errout is Nxt : Error_Msg_Id; F : Error_Msg_Id; + procedure Delete_Warning (E : Error_Msg_Id); + -- Delete a message if not already deleted and adjust warning count + + -------------------- + -- Delete_Warning -- + -------------------- + + procedure Delete_Warning (E : Error_Msg_Id) is + begin + if not Errors.Table (E).Deleted then + Errors.Table (E).Deleted := True; + Warnings_Detected := Warnings_Detected - 1; + end if; + end Delete_Warning; + + -- Start of message for Finalize + begin + -- Set Prev pointers + + Cur := First_Error_Msg; + while Cur /= No_Error_Msg loop + Nxt := Errors.Table (Cur).Next; + exit when Nxt = No_Error_Msg; + Errors.Table (Nxt).Prev := Cur; + Cur := Nxt; + end loop; + -- Eliminate any duplicated error messages from the list. This is -- done after the fact to avoid problems with Change_Error_Text. @@ -1242,11 +1267,27 @@ package body Errout is while Cur /= No_Error_Msg loop if not Errors.Table (Cur).Deleted and then Warning_Specifically_Suppressed - (Errors.Table (Cur).Sptr, - Errors.Table (Cur).Text) + (Errors.Table (Cur).Sptr, Errors.Table (Cur).Text) then - Errors.Table (Cur).Deleted := True; - Warnings_Detected := Warnings_Detected - 1; + Delete_Warning (Cur); + + -- If this is a continuation, delete previous messages + + F := Cur; + while Errors.Table (F).Msg_Cont loop + F := Errors.Table (F).Prev; + Delete_Warning (F); + end loop; + + -- Delete any following continuations + + F := Cur; + loop + F := Errors.Table (F).Next; + exit when F = No_Error_Msg; + exit when not Errors.Table (F).Msg_Cont; + Delete_Warning (F); + end loop; end if; Cur := Errors.Table (Cur).Next; @@ -1325,13 +1366,12 @@ package body Errout is S := Sloc (F); -- The following circuit is a bit subtle. When we have parenthesized - -- expressions, then the Sloc will not record the location of the - -- paren, but we would like to post the flag on the paren. So what - -- we do is to crawl up the tree from the First_Node, adjusting the - -- Sloc value for any parentheses we know are present. Yes, we know - -- this circuit is not 100% reliable (e.g. because we don't record - -- all possible paren level values), but this is only for an error - -- message so it is good enough. + -- expressions, then the Sloc will not record the location of the paren, + -- but we would like to post the flag on the paren. So what we do is to + -- crawl up the tree from the First_Node, adjusting the Sloc value for + -- any parentheses we know are present. Yes, we know this circuit is not + -- 100% reliable (e.g. because we don't record all possible paren level + -- values), but this is only for an error message so it is good enough. Node_Loop : loop Paren_Loop : for J in 1 .. Paren_Count (F) loop @@ -1378,8 +1418,8 @@ package body Errout is Cur_Msg := No_Error_Msg; List_Pragmas.Init; - -- Initialize warnings table, if all warnings are suppressed, supply - -- an initial dummy entry covering all possible source locations. + -- Initialize warnings table, if all warnings are suppressed, supply an + -- initial dummy entry covering all possible source locations. Warnings.Init; Specific_Warnings.Init; @@ -2100,12 +2140,12 @@ package body Errout is Flen := Flen + 1; end loop; - -- Loop through file names to find matching one. This is a bit slow, - -- but we only do it in error situations so it is not so terrible. - -- Note that if the loop does not exit, then the desired case will - -- be left set to Mixed_Case, this can happen if the name was not - -- in canonical form, and gets canonicalized on VMS. Possibly we - -- could fix this by unconditinally canonicalizing these names ??? + -- Loop through file names to find matching one. This is a bit slow, but + -- we only do it in error situations so it is not so terrible. Note that + -- if the loop does not exit, then the desired case will be left set to + -- Mixed_Case, this can happen if the name was not in canonical form, + -- and gets canonicalized on VMS. Possibly we could fix this by + -- unconditinally canonicalizing these names ??? for J in 1 .. Last_Source_File loop Get_Name_String (Full_Debug_Name (J)); @@ -2185,9 +2225,9 @@ package body Errout is K := Nkind (Error_Msg_Node_1); -- If we have operator case, skip quotes since name of operator - -- itself will supply the required quotations. An operator can be - -- an applied use in an expression or an explicit operator symbol, - -- or an identifier whose name indicates it is an operator. + -- itself will supply the required quotations. An operator can be an + -- applied use in an expression or an explicit operator symbol, or an + -- identifier whose name indicates it is an operator. if K in N_Op or else K = N_Operator_Symbol @@ -2333,8 +2373,8 @@ package body Errout is Set_Msg_Node (Ent); Add_Class; - -- If Ent is an anonymous subprogram type, there is no name - -- to print, so remove enclosing quotes. + -- If Ent is an anonymous subprogram type, there is no name to print, + -- so remove enclosing quotes. if Buffer_Ends_With ("""") then Buffer_Remove (""""); @@ -2343,8 +2383,8 @@ package body Errout is end if; end if; - -- If the original type did not come from a predefined - -- file, add the location where the type was defined. + -- If the original type did not come from a predefined file, add the + -- location where the type was defined. if Sloc (Error_Msg_Node_1) > Standard_Location and then @@ -2504,7 +2544,7 @@ package body Errout is -- in case, which is the case when we can copy from the source. declare - Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1); + Src_Loc : constant Source_Ptr := Sloc (Node); Sbuffer : Source_Buffer_Ptr; Ref_Ptr : Integer; Src_Ptr : Source_Ptr; @@ -2521,9 +2561,9 @@ package body Errout is Set_Casing (Mixed_Case); else - -- Determine if the reference we are dealing with corresponds - -- to text at the point of the error reference. This will often - -- be the case for simple identifier references, and is the case + -- Determine if the reference we are dealing with corresponds to + -- text at the point of the error reference. This will often be + -- the case for simple identifier references, and is the case -- where we can copy the spelling from the source. Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc)); @@ -2536,8 +2576,8 @@ package body Errout is Src_Ptr := Src_Ptr + 1; end loop; - -- If we get through the loop without a mismatch, then output - -- the name the way it is spelled in the source program + -- If we get through the loop without a mismatch, then output the + -- name the way it is spelled in the source program if Ref_Ptr > Name_Len then Src_Ptr := Src_Loc; @@ -2572,8 +2612,8 @@ package body Errout is Is_Unconditional_Msg := False; Msglen := 0; Flag_Source := Get_Source_File_Index (Flag); - P := Text'First; + P := Text'First; while P <= Text'Last loop C := Text (P); P := P + 1; @@ -2829,7 +2869,7 @@ package body Errout is -- "type derived from" message more than once in the case where we climb -- up multiple levels. - loop + Find : loop Old_Ent := Ent; -- Implicit access type, use directly designated type In Ada 2005, @@ -2877,7 +2917,7 @@ package body Errout is Set_Msg_Str ("access to procedure "); end if; - exit; + exit Find; -- Type is access to object, named or anonymous @@ -2915,51 +2955,54 @@ package body Errout is -- itself an internal name. This avoids the obvious loop (subtype -> -- basetype -> subtype) which would otherwise occur!) - elsif Present (Freeze_Node (Ent)) - and then Present (First_Subtype_Link (Freeze_Node (Ent))) - and then - not Is_Internal_Name - (Chars (First_Subtype_Link (Freeze_Node (Ent)))) - then - Ent := First_Subtype_Link (Freeze_Node (Ent)); + else + declare + FST : constant Entity_Id := First_Subtype (Ent); - -- Otherwise use root type + begin + if not Is_Internal_Name (Chars (FST)) then + Ent := FST; + exit Find; - else - if not Derived then - Buffer_Remove ("type "); + -- Otherwise use root type - -- Test for "subtype of type derived from" which seems - -- excessive and is replaced by simply "type derived from" + else + if not Derived then + Buffer_Remove ("type "); - Buffer_Remove ("subtype of"); + -- Test for "subtype of type derived from" which seems + -- excessive and is replaced by "type derived from". - -- Avoid duplication "type derived from type derived from" + Buffer_Remove ("subtype of"); - if not Buffer_Ends_With ("type derived from ") then - Set_Msg_Str ("type derived from "); - end if; + -- Avoid duplicated "type derived from type derived from" - Derived := True; - end if; + if not Buffer_Ends_With ("type derived from ") then + Set_Msg_Str ("type derived from "); + end if; + + Derived := True; + end if; + end if; + end; Ent := Etype (Ent); end if; -- If we are stuck in a loop, get out and settle for the internal - -- name after all. In this case we set to kill the message if it - -- is not the first error message (we really try hard not to show - -- the dirty laundry of the implementation to the poor user!) + -- name after all. In this case we set to kill the message if it is + -- not the first error message (we really try hard not to show the + -- dirty laundry of the implementation to the poor user!) if Ent = Old_Ent then Kill_Message := True; - exit; + exit Find; end if; -- Get out if we finally found a non-internal name to use - exit when not Is_Internal_Name (Chars (Ent)); - end loop; + exit Find when not Is_Internal_Name (Chars (Ent)); + end loop Find; if Mchar = '"' then Set_Msg_Char ('"'); diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index e4d8a62e6dc..8251126f341 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -376,6 +376,9 @@ package Errout is Gname5 : aliased constant String := "gnat05"; Vname5 : aliased constant String := "05"; + Gname6 : aliased constant String := "gnat12"; + Vname6 : aliased constant String := "12"; + type Cstring_Ptr is access constant String; Gnames : array (Nat range <>) of Cstring_Ptr := @@ -383,14 +386,16 @@ package Errout is Gname2'Access, Gname3'Access, Gname4'Access, - Gname5'Access); + Gname5'Access, + Gname6'Access); Vnames : array (Nat range <>) of Cstring_Ptr := (Vname1'Access, Vname2'Access, Vname3'Access, Vname4'Access, - Vname5'Access); + Vname5'Access, + Vname6'Access); ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- @@ -601,13 +606,6 @@ package Errout is -- without appropriate coordination. If new messages are added which may -- be susceptible to automatic codefix action, they are marked using: - -- Error_Msg -- CODEFIX??? - -- (parameters) - - -- And subsequently either the appropriate code is added to codefix and the - -- ??? are removed, or it is determined that this is not an appropriate - -- case for codefix action, and the comment is removed. - ------------------------------ -- Error Output Subprograms -- ------------------------------ diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index f2127deaa39..d7628ed01ca 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -147,6 +147,11 @@ package Erroutc is -- Pointer to next message in error chain. A value of No_Error_Msg -- indicates the end of the chain. + Prev : Error_Msg_Id; + -- Pointer to previous message in error chain. Only set during the + -- Finalize procedure. A value of No_Error_Msg indicates the first + -- message in the chain. + Sfile : Source_File_Index; -- Source table index of source file. In the case of an error that -- refers to a template, always references the original template diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index dc6c8bb90d0..36045190d53 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -93,7 +93,7 @@ package body Exp_Aggr is function Has_Default_Init_Comps (N : Node_Id) return Boolean; -- N is an aggregate (record or array). Checks the presence of default - -- initialization (<>) in any component (Ada 2005: AI-287) + -- initialization (<>) in any component (Ada 2005: AI-287). function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean; -- Returns true if N is an aggregate used to initialize the components @@ -173,14 +173,15 @@ package body Exp_Aggr is ----------------------------------------------------- function Aggr_Size_OK (N : Node_Id; Typ : Entity_Id) return Boolean; - -- Very large static aggregates present problems to the back-end, and - -- are transformed into assignments and loops. This function verifies - -- that the total number of components of an aggregate is acceptable - -- for transformation into a purely positional static form. It is called - -- prior to calling Flatten. - -- This function also detects and warns about one-component aggregates - -- that appear in a non-static context. Even if the component value is - -- static, such an aggregate must be expanded into an assignment. + -- Very large static aggregates present problems to the back-end, and are + -- transformed into assignments and loops. This function verifies that the + -- total number of components of an aggregate is acceptable for rewriting + -- into a purely positional static form. Aggr_Size_OK must be called before + -- calling Flatten. + -- + -- This function also detects and warns about one-component aggregates that + -- appear in a non-static context. Even if the component value is static, + -- such an aggregate must be expanded into an assignment. procedure Convert_Array_Aggr_In_Allocator (Decl : Node_Id; @@ -1347,7 +1348,7 @@ package body Exp_Aggr is -- Otherwise construct the loop, starting with the loop index L_J - L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + L_J := Make_Temporary (Loc, 'J', L); -- Construct "L .. H" in Index_Base. We use a qualified expression -- for the bound to convert to the index base, but we don't need @@ -1455,7 +1456,7 @@ package body Exp_Aggr is -- Build the decl of W_J - W_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + W_J := Make_Temporary (Loc, 'J', L); W_Decl := Make_Object_Declaration (Loc, @@ -2426,14 +2427,16 @@ package body Exp_Aggr is function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is begin - if Nkind (Expr) = N_Identifier + if Is_Entity_Name (Expr) and then Present (Entity (Expr)) and then Ekind (Entity (Expr)) = E_In_Parameter and then Present (Discriminal_Link (Entity (Expr))) + and then Scope (Discriminal_Link (Entity (Expr))) + = Base_Type (Etype (N)) then Rewrite (Expr, Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj, Loc), + Prefix => New_Copy_Tree (Lhs), Selector_Name => Make_Identifier (Loc, Chars (Expr)))); end if; return OK; @@ -2860,14 +2863,14 @@ package body Exp_Aggr is if Is_CPP_Constructor_Call (Expression (Comp)) then Append_List_To (L, Build_Initialization_Call (Loc, - Id_Ref => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of (Selector, - Loc)), - Typ => Etype (Selector), - Enclos_Type => Typ, + Id_Ref => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Selector, Loc)), + Typ => Etype (Selector), + Enclos_Type => Typ, With_Default_Init => True, - Constructor_Ref => Expression (Comp))); + Constructor_Ref => Expression (Comp))); -- Ada 2005 (AI-287): For each default-initialized component generate -- a call to the corresponding IP subprogram if available. @@ -2886,8 +2889,8 @@ package body Exp_Aggr is declare Ctype : constant Entity_Id := Etype (Selector); - Inside_Allocator : Boolean := False; - P : Node_Id := Parent (N); + Inside_Allocator : Boolean := False; + P : Node_Id := Parent (N); begin if Is_Task_Type (Ctype) or else Has_Task (Ctype) then @@ -2908,12 +2911,12 @@ package body Exp_Aggr is Append_List_To (L, Build_Initialization_Call (Loc, - Id_Ref => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of (Selector, - Loc)), - Typ => Etype (Selector), - Enclos_Type => Typ, + Id_Ref => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Selector, Loc)), + Typ => Etype (Selector), + Enclos_Type => Typ, With_Default_Init => True)); -- Prepare for component assignment @@ -3008,9 +3011,7 @@ package body Exp_Aggr is -- the corresponding aggregate. declare - SubE : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); SubD : constant Node_Id := Make_Subtype_Declaration (Loc, @@ -3784,10 +3785,11 @@ package body Exp_Aggr is Rep_Count : Nat; -- Used to validate Max_Others_Replicate limit - Elmt : Node_Id; - Num : Int := UI_To_Int (Lov); - Choice : Node_Id; - Lo, Hi : Node_Id; + Elmt : Node_Id; + Num : Int := UI_To_Int (Lov); + Choice_Index : Int; + Choice : Node_Id; + Lo, Hi : Node_Id; begin if Present (Expressions (N)) then @@ -3913,9 +3915,18 @@ package body Exp_Aggr is return False; else - Vals (UI_To_Int (Expr_Value (Choice))) := - New_Copy_Tree (Expression (Elmt)); - goto Continue; + Choice_Index := UI_To_Int (Expr_Value (Choice)); + if Choice_Index in Vals'Range then + Vals (Choice_Index) := + New_Copy_Tree (Expression (Elmt)); + goto Continue; + + else + -- Choice is statically out-of-range, will be + -- rewritten to raise Constraint_Error. + + return False; + end if; end if; end if; @@ -4139,7 +4150,7 @@ package body Exp_Aggr is procedure Build_Constrained_Type (Positional : Boolean) is Loc : constant Source_Ptr := Sloc (N); - Agg_Type : Entity_Id; + Agg_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); Comp : Node_Id; Decl : Node_Id; Typ : constant Entity_Id := Etype (N); @@ -4148,10 +4159,6 @@ package body Exp_Aggr is Sub_Agg : Node_Id; begin - Agg_Type := - Make_Defining_Identifier ( - Loc, New_Internal_Name ('A')); - -- If the aggregate is purely positional, all its subaggregates -- have the same size. We collect the dimensions from the first -- subaggregate at each level. @@ -4169,19 +4176,16 @@ package body Exp_Aggr is Next (Comp); end loop; - Append ( + Append_To (Indices, Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), - High_Bound => - Make_Integer_Literal (Loc, Num)), - Indices); + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => Make_Integer_Literal (Loc, Num))); end loop; else -- We know the aggregate type is unconstrained and the aggregate -- is not processable by the back end, therefore not necessarily -- positional. Retrieve each dimension bounds (computed earlier). - -- earlier. for D in 1 .. Number_Dimensions (Typ) loop Append ( @@ -5693,9 +5697,7 @@ package body Exp_Aggr is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => @@ -6384,9 +6386,8 @@ package body Exp_Aggr is and then Nkind (First (Choices (First (Component_Associations (N))))) = N_Others_Choice then - Expr := - Expression (First (Component_Associations (N))); - L_J := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Expr := Expression (First (Component_Associations (N))); + L_J := Make_Temporary (Loc, 'J'); L_Iter := Make_Iteration_Scheme (Loc, diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index d5cdf0b79b7..23a9202c372 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -150,14 +150,10 @@ package body Exp_Atag is Related_Nod : Node_Id; New_Node : out Node_Id) is - Tag_Addr : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); - Obj_TSD : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); - Typ_TSD : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); - Index : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('D')); + Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node); + Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); + Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); + Index : constant Entity_Id := Make_Temporary (Loc, 'D'); begin -- Generate: diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 7f7e1d1cc82..5126e5a1730 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -280,16 +280,14 @@ package body Exp_Attr is -- Start of processing for Expand_Access_To_Protected_Op begin - -- Within the body of the protected type, the prefix - -- designates a local operation, and the object is the first - -- parameter of the corresponding protected body of the - -- current enclosing operation. + -- Within the body of the protected type, the prefix designates a local + -- operation, and the object is the first parameter of the corresponding + -- protected body of the current enclosing operation. if Is_Entity_Name (Pref) then if May_Be_External_Call then Sub := - New_Occurrence_Of - (External_Subprogram (Entity (Pref)), Loc); + New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); else Sub := New_Occurrence_Of @@ -372,6 +370,7 @@ package body Exp_Attr is Make_Aggregate (Loc, Expressions => New_List (Obj_Ref, Sub_Ref)); + Freeze_Before (N, Entity (Sub)); Rewrite (N, Agg); Analyze_And_Resolve (N, E_T); @@ -530,9 +529,7 @@ package body Exp_Attr is and then Is_Written then declare - Temp : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('V')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'V'); Decl : Node_Id; Assn : Node_Id; @@ -1208,6 +1205,20 @@ package body Exp_Attr is Analyze_And_Resolve (N, RTE (RE_AST_Handler)); end AST_Entry; + --------- + -- Bit -- + --------- + + -- We compute this if a packed array reference was present, otherwise we + -- leave the computation up to the back end. + + when Attribute_Bit => + if Involves_Packed_Array_Reference (Pref) then + Expand_Packed_Bit_Reference (N); + else + Apply_Universal_Integer_Attribute_Checks (N); + end if; + ------------------ -- Bit_Position -- ------------------ @@ -1220,8 +1231,7 @@ package body Exp_Attr is -- in generated code (i.e. the prefix is an identifier that -- references the component or discriminant entity). - when Attribute_Bit_Position => Bit_Position : - declare + when Attribute_Bit_Position => Bit_Position : declare CE : Entity_Id; begin @@ -1259,12 +1269,11 @@ package body Exp_Attr is -- subprogram spec or package. This sequence of code references the -- the unsigned constant created in the main program by the binder. - -- A special exception occurs for Standard, where the string - -- returned is a copy of the library string in gnatvsn.ads. + -- A special exception occurs for Standard, where the string returned + -- is a copy of the library string in gnatvsn.ads. when Attribute_Body_Version | Attribute_Version => Version : declare - E : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + E : constant Entity_Id := Make_Temporary (Loc, 'V'); Pent : Entity_Id; S : String_Id; @@ -1777,9 +1786,7 @@ package body Exp_Attr is Attribute_Elab_Spec => Elab_Body : declare - Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('E')); + Ent : constant Entity_Id := Make_Temporary (Loc, 'E'); Str : String_Id; Lang : Node_Id; @@ -2389,13 +2396,14 @@ package body Exp_Attr is Rtyp : constant Entity_Id := Root_Type (P_Type); Dnn : Entity_Id; Decl : Node_Id; + Expr : Node_Id; begin -- Read the internal tag (RM 13.13.2(34)) and use it to -- initialize a dummy tag object: - -- Dnn : Ada.Tags.Tag - -- := Descendant_Tag (String'Input (Strm), P_Type); + -- Dnn : Ada.Tags.Tag := + -- Descendant_Tag (String'Input (Strm), P_Type); -- This dummy object is used only to provide a controlling -- argument for the eventual _Input call. Descendant_Tag is @@ -2406,30 +2414,28 @@ package body Exp_Attr is -- required for Ada 2005 because tagged types can be -- extended in nested scopes (AI-344). - Dnn := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('D')); + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))), + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (P_Type, Loc), + Attribute_Name => Name_Tag))); + + Dnn := Make_Temporary (Loc, 'D', Expr); Decl := Make_Object_Declaration (Loc, Defining_Identifier => Dnn, - Object_Definition => + Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Standard_String, Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( - Relocate_Node - (Duplicate_Subexpr (Strm)))), - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (P_Type, Loc), - Attribute_Name => Name_Tag)))); + Expression => Expr); Insert_Action (N, Decl); @@ -2440,8 +2446,9 @@ package body Exp_Attr is -- tagged object). Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); - Cntrl := Unchecked_Convert_To (P_Type, - New_Occurrence_Of (Dnn, Loc)); + Cntrl := + Unchecked_Convert_To (P_Type, + New_Occurrence_Of (Dnn, Loc)); Set_Etype (Cntrl, P_Type); Set_Parent (Cntrl, N); end; @@ -2987,9 +2994,7 @@ package body Exp_Attr is --------- when Attribute_Old => Old : declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', Pref); Subp : Node_Id; Asn_Stm : Node_Id; @@ -3239,9 +3244,9 @@ package body Exp_Attr is -- For enumeration types with a standard representation, Pos is -- handled by the back end. - -- For enumeration types, with a non-standard representation we - -- generate a call to the _Rep_To_Pos function created when the - -- type was frozen. The call has the form + -- For enumeration types, with a non-standard representation we generate + -- a call to the _Rep_To_Pos function created when the type was frozen. + -- The call has the form -- _rep_to_pos (expr, flag) @@ -3548,6 +3553,7 @@ package body Exp_Attr is ------------------ when Attribute_Range_Length => Range_Length : begin + -- The only special processing required is for the case where -- Range_Length is applied to an enumeration type with holes. -- In this case we transform @@ -4264,8 +4270,7 @@ package body Exp_Attr is -- 2. For floating-point, generate call to attribute function -- 3. For other cases, deal with constraint checking - when Attribute_Succ => Succ : - declare + when Attribute_Succ => Succ : declare Etyp : constant Entity_Id := Base_Type (Ptyp); begin @@ -4357,8 +4362,7 @@ package body Exp_Attr is -- Transforms X'Tag into a direct reference to the tag of X - when Attribute_Tag => Tag : - declare + when Attribute_Tag => Tag : declare Ttyp : Entity_Id; Prefix_Is_Type : Boolean; @@ -4552,8 +4556,7 @@ package body Exp_Attr is ----------------- when Attribute_UET_Address => UET_Address : declare - Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Insert_Action (N, @@ -4606,8 +4609,7 @@ package body Exp_Attr is -- with a non-standard representation we use the _Pos_To_Rep array that -- was created when the type was frozen. - when Attribute_Val => Val : - declare + when Attribute_Val => Val : declare Etyp : constant Entity_Id := Base_Type (Entity (Pref)); begin @@ -4670,8 +4672,7 @@ package body Exp_Attr is -- The code for valid is dependent on the particular types involved. -- See separate sections below for the generated code in each case. - when Attribute_Valid => Valid : - declare + when Attribute_Valid => Valid : declare Btyp : Entity_Id := Base_Type (Ptyp); Tst : Node_Id; @@ -4731,6 +4732,13 @@ package body Exp_Attr is -- Start of processing for Attribute_Valid begin + -- Do not expand sourced code 'Valid reference in CodePeer mode, + -- will be handled by the back-end directly. + + if CodePeer_Mode and then Comes_From_Source (N) then + return; + end if; + -- Turn off validity checks. We do not want any implicit validity -- checks to intefere with the explicit check from the attribute @@ -5275,7 +5283,6 @@ package body Exp_Attr is -- that the result is in range. when Attribute_Aft | - Attribute_Bit | Attribute_Max_Size_In_Storage_Elements => Apply_Universal_Integer_Attribute_Checks (N); diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb new file mode 100644 index 00000000000..e7decc8f1e7 --- /dev/null +++ b/gcc/ada/exp_cg.adb @@ -0,0 +1,602 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Disp; use Exp_Disp; +with Exp_Dbug; use Exp_Dbug; +with Exp_Tss; use Exp_Tss; +with Lib; use Lib; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Sem_Aux; use Sem_Aux; +with Sem_Disp; use Sem_Disp; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Sinput; use Sinput; +with Snames; use Snames; +with System; use System; +with Table; +with Uintp; use Uintp; + +package body Exp_CG is + + -- We duplicate here some declarations from packages Interfaces.C and + -- Interfaces.C_Streams because adding their dependence to the frontend + -- causes bootstrapping problems with old versions of the compiler. + + subtype FILEs is System.Address; + -- Corresponds to the C type FILE* + + subtype C_chars is System.Address; + -- Pointer to null-terminated array of characters + + function fputs (Strng : C_chars; Stream : FILEs) return Integer; + pragma Import (C, fputs, "fputs"); + + -- Import the file stream associated with the "ci" output file. Done to + -- generate the output in the file created and left opened by routine + -- toplev.c before calling gnat1drv. + + Callgraph_Info_File : FILEs; + pragma Import (C, Callgraph_Info_File); + + package Call_Graph_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Call_Graph_Nodes"); + -- This table records nodes associated with dispatching calls and tagged + -- type declarations found in the main compilation unit. Used as an + -- auxiliary storage because the call-graph output requires fully qualified + -- names and they are not available until the backend is called. + + function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; + -- Determines if E is a predefined primitive operation. + -- Note: This routine should replace the routine with the same name that is + -- currently available in exp_disp because it extends its functionality to + -- handle fully qualified names ??? + + function Slot_Number (Prim : Entity_Id) return Uint; + -- Returns the slot number associated with Prim. For predefined primitives + -- the slot is returned as a negative number. + + procedure Write_Output (Str : String); + -- Used to print a line in the output file (this is used as the + -- argument for a call to Set_Special_Output in package Output). + + procedure Write_Call_Info (Call : Node_Id); + -- Subsidiary of Generate_CG_Output that generates the output associated + -- with a dispatching call. + + procedure Write_Type_Info (Typ : Entity_Id); + -- Subsidiary of Generate_CG_Output that generates the output associated + -- with a tagged type declaration. + + ------------------------ + -- Generate_CG_Output -- + ------------------------ + + procedure Generate_CG_Output is + N : Node_Id; + + begin + -- No output if the "ci" output file has not been previously opened + -- by toplev.c. Temporarily the output is also disabled with -gnatd.Z + + if Callgraph_Info_File = Null_Address + or else not Debug_Flag_Dot_ZZ + then + return; + end if; + + -- Setup write routine, create the output file and generate the output + + Set_Special_Output (Write_Output'Access); + + for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop + N := Call_Graph_Nodes.Table (J); + + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then + Write_Call_Info (N); + + else pragma Assert (Nkind (N) = N_Defining_Identifier); + pragma Assert (Is_Tagged_Type (N)); + + Write_Type_Info (N); + end if; + end loop; + + Set_Special_Output (null); + end Generate_CG_Output; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Call_Graph_Nodes.Init; + end Initialize; + + ----------------------------------------- + -- Is_Predefined_Dispatching_Operation -- + ----------------------------------------- + + function Is_Predefined_Dispatching_Operation + (E : Entity_Id) return Boolean + is + function Homonym_Suffix_Length (E : Entity_Id) return Natural; + -- Returns the length of the homonym suffix corresponding to E. + -- Note: This routine relies on the functionality provided by routines + -- of Exp_Dbug. Further work needed here to decide if it should be + -- located in that package??? + + --------------------------- + -- Homonym_Suffix_Length -- + --------------------------- + + function Homonym_Suffix_Length (E : Entity_Id) return Natural is + Prefix_Length : constant := 2; -- Length of prefix "__" + + H : Entity_Id; + Nr : Nat := 1; + + begin + if not Has_Homonym (E) then + return 0; + + else + H := Homonym (E); + while Present (H) loop + if Scope (H) = Scope (E) then + Nr := Nr + 1; + end if; + + H := Homonym (H); + end loop; + + if Nr = 1 then + return 0; + + -- Prefix "__" followed by number + + else + declare + Result : Natural := Prefix_Length + 1; + begin + while Nr > 10 loop + Result := Result + 1; + Nr := Nr / 10; + end loop; + return Result; + end; + end if; + end if; + end Homonym_Suffix_Length; + + -- Local variables + + Full_Name : constant String := Get_Name_String (Chars (E)); + TSS_Name : TSS_Name_Type; + + -- Start of processing for Is_Predefined_Dispatching_Operation + + begin + if not Is_Dispatching_Operation (E) then + return False; + end if; + + -- Most predefined primitives have internally generated names. Equality + -- must be treated differently; the predefined operation is recognized + -- as a homogeneous binary operator that returns Boolean. + + if Full_Name'Length > TSS_Name_Type'Length then + TSS_Name := + TSS_Name_Type (Full_Name (Full_Name'Last - TSS_Name'Length + 1 + .. Full_Name'Last)); + + if TSS_Name = TSS_Stream_Read + or else TSS_Name = TSS_Stream_Write + or else TSS_Name = TSS_Stream_Input + or else TSS_Name = TSS_Stream_Output + or else TSS_Name = TSS_Deep_Adjust + or else TSS_Name = TSS_Deep_Finalize + then + return True; + + elsif not Has_Fully_Qualified_Name (E) then + if Chars (E) = Name_uSize + or else Chars (E) = Name_uAlignment + or else + (Chars (E) = Name_Op_Eq + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) + or else Chars (E) = Name_uAssign + or else Is_Predefined_Interface_Primitive (E) + then + return True; + end if; + + -- Handle fully qualified names + + else + declare + type Names_Table is array (Positive range <>) of Name_Id; + + Predef_Names_95 : constant Names_Table := + (Name_uSize, + Name_uAlignment, + Name_Op_Eq, + Name_uAssign); + + Predef_Names_05 : constant Names_Table := + (Name_uDisp_Asynchronous_Select, + Name_uDisp_Conditional_Select, + Name_uDisp_Get_Prim_Op_Kind, + Name_uDisp_Get_Task_Id, + Name_uDisp_Requeue, + Name_uDisp_Timed_Select); + + Suffix_Length : constant Natural := Homonym_Suffix_Length (E); + + begin + for J in Predef_Names_95'Range loop + Get_Name_String (Predef_Names_95 (J)); + + if Full_Name'Last - Suffix_Length > Name_Len + and then + Full_Name + (Full_Name'Last - Name_Len - Suffix_Length + 1 + .. Full_Name'Last - Suffix_Length) = + Name_Buffer (1 .. Name_Len) + then + -- For the equality operator the type of the two operands + -- must also match. + + return Predef_Names_95 (J) /= Name_Op_Eq + or else + Etype (First_Formal (E)) = Etype (Last_Formal (E)); + end if; + end loop; + + if Ada_Version >= Ada_05 then + for J in Predef_Names_05'Range loop + Get_Name_String (Predef_Names_05 (J)); + + if Full_Name'Last - Suffix_Length > Name_Len + and then + Full_Name + (Full_Name'Last - Name_Len - Suffix_Length + 1 + .. Full_Name'Last - Suffix_Length) = + Name_Buffer (1 .. Name_Len) + then + return True; + end if; + end loop; + end if; + end; + end if; + end if; + + return False; + end Is_Predefined_Dispatching_Operation; + + ---------------------- + -- Register_CG_Node -- + ---------------------- + + procedure Register_CG_Node (N : Node_Id) is + begin + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then + if Current_Scope = Main_Unit_Entity + or else Entity_Is_In_Main_Unit (Current_Scope) + then + -- Register a copy of the dispatching call node. Needed since the + -- node containing a dispatching call is rewriten by the expander. + + declare + Copy : constant Node_Id := New_Copy (N); + + begin + -- Copy the link to the parent to allow climbing up the tree + -- when the call-graph information is generated + + Set_Parent (Copy, Parent (N)); + Call_Graph_Nodes.Append (Copy); + end; + end if; + + else pragma Assert (Nkind (N) = N_Defining_Identifier); + if Entity_Is_In_Main_Unit (N) then + Call_Graph_Nodes.Append (N); + end if; + end if; + end Register_CG_Node; + + ----------------- + -- Slot_Number -- + ----------------- + + function Slot_Number (Prim : Entity_Id) return Uint is + begin + if Is_Predefined_Dispatching_Operation (Prim) then + return -DT_Position (Prim); + else + return DT_Position (Prim); + end if; + end Slot_Number; + + ------------------ + -- Write_Output -- + ------------------ + + procedure Write_Output (Str : String) is + Nul : constant Character := Character'First; + Line : String (Str'First .. Str'Last + 1); + Errno : Integer; + begin + -- Add the null character to the string as required by fputs + + Line := Str & Nul; + Errno := fputs (Line'Address, Callgraph_Info_File); + pragma Assert (Errno >= 0); + end Write_Output; + + --------------------- + -- Write_Call_Info -- + --------------------- + + procedure Write_Call_Info (Call : Node_Id) is + Ctrl_Arg : constant Node_Id := Controlling_Argument (Call); + Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); + Prim : constant Entity_Id := Entity (Sinfo.Name (Call)); + P : Node_Id; + + begin + -- Locate the enclosing context: a subprogram (if available) or the + -- enclosing library-level package + + P := Parent (Call); + while Nkind (P) /= N_Subprogram_Body + and then Nkind (Parent (P)) /= N_Compilation_Unit + loop + P := Parent (P); + pragma Assert (Present (P)); + end loop; + + Write_Str ("edge: { sourcename: "); + Write_Char ('"'); + Get_External_Name (Defining_Entity (P), Has_Suffix => False); + Write_Str (Name_Buffer (1 .. Name_Len)); + + if Nkind (P) = N_Package_Declaration then + Write_Str ("___elabs"); + + elsif Nkind (P) = N_Package_Body then + Write_Str ("___elabb"); + end if; + + Write_Char ('"'); + Write_Eol; + + -- The targetname is a triple: + -- N: the index in a vtable used for dispatch + -- V: the type who's vtable is used + -- S: the static type of the expression + + Write_Str (" targetname: "); + Write_Char ('"'); + + pragma Assert (No (Interface_Alias (Prim))); + + -- The check on Is_Ancestor is done here to avoid problems with + -- renamings of primitives. For example: + + -- type Root is tagged ... + -- procedure Base (Obj : Root); + -- procedure Base2 (Obj : Root) renames Base; + + if Present (Alias (Prim)) + and then + Is_Ancestor + (Find_Dispatching_Type (Ultimate_Alias (Prim)), + Root_Type (Ctrl_Typ)) + then + Write_Int (UI_To_Int (Slot_Number (Ultimate_Alias (Prim)))); + Write_Char (':'); + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Int (UI_To_Int (Slot_Number (Prim))); + Write_Char (':'); + Write_Name (Chars (Root_Type (Ctrl_Typ))); + end if; + + Write_Char (','); + Write_Name (Chars (Root_Type (Ctrl_Typ))); + + Write_Char ('"'); + Write_Eol; + + Write_Str (" label: "); + Write_Char ('"'); + Write_Location (Sloc (Call)); + Write_Char ('"'); + Write_Eol; + + Write_Char ('}'); + Write_Eol; + end Write_Call_Info; + + --------------------- + -- Write_Type_Info -- + --------------------- + + procedure Write_Type_Info (Typ : Entity_Id) is + Elmt : Elmt_Id; + Prim : Node_Id; + + Parent_Typ : Entity_Id; + Separator_Needed : Boolean := False; + + begin + -- Initialize Parent_Typ handling private types + + Parent_Typ := Etype (Typ); + + if Present (Full_View (Parent_Typ)) then + Parent_Typ := Full_View (Parent_Typ); + end if; + + Write_Str ("class {"); + Write_Eol; + + Write_Str (" classname: "); + Write_Char ('"'); + Write_Name (Chars (Typ)); + Write_Char ('"'); + Write_Eol; + + Write_Str (" label: "); + Write_Char ('"'); + Write_Name (Chars (Typ)); + Write_Char ('\'); + Write_Location (Sloc (Typ)); + Write_Char ('"'); + Write_Eol; + + if Parent_Typ /= Typ then + Write_Str (" parent: "); + Write_Char ('"'); + Write_Name (Chars (Parent_Typ)); + + -- Note: Einfo prefix not needed if this routine is moved to + -- exp_disp??? + + if Present (Einfo.Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ)) + then + Elmt := First_Elmt (Einfo.Interfaces (Typ)); + while Present (Elmt) loop + Write_Str (", "); + Write_Name (Chars (Node (Elmt))); + Next_Elmt (Elmt); + end loop; + end if; + + Write_Char ('"'); + Write_Eol; + end if; + + Write_Str (" virtuals: "); + Write_Char ('"'); + + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); + + -- Display only primitives overriden or defined + + if Present (Alias (Prim)) then + goto Continue; + end if; + + -- Do not generate separator for output of first primitive + + if Separator_Needed then + Write_Str ("\n"); + Write_Eol; + Write_Str (" "); + else + Separator_Needed := True; + end if; + + Write_Int (UI_To_Int (Slot_Number (Prim))); + Write_Char (':'); + Write_Name (Chars (Prim)); + + -- Display overriding of parent primitives + + if Present (Overridden_Operation (Prim)) + and then + Is_Ancestor + (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ) + then + Write_Char (','); + Write_Int + (UI_To_Int (Slot_Number (Overridden_Operation (Prim)))); + Write_Char (':'); + Write_Name + (Chars (Find_Dispatching_Type (Overridden_Operation (Prim)))); + end if; + + -- Display overriding of interface primitives + + if Has_Interfaces (Typ) then + declare + Prim_Elmt : Elmt_Id; + Prim_Op : Node_Id; + Int_Alias : Entity_Id; + + begin + Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Prim_Elmt) loop + Prim_Op := Node (Prim_Elmt); + Int_Alias := Interface_Alias (Prim_Op); + + if Present (Int_Alias) + and then not Is_Ancestor + (Find_Dispatching_Type (Int_Alias), Typ) + and then (Alias (Prim_Op)) = Prim + then + Write_Char (','); + Write_Int (UI_To_Int (Slot_Number (Int_Alias))); + Write_Char (':'); + Write_Name (Chars (Find_Dispatching_Type (Int_Alias))); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end; + end if; + + <<Continue>> + Next_Elmt (Elmt); + end loop; + + Write_Char ('"'); + Write_Eol; + + Write_Char ('}'); + Write_Eol; + end Write_Type_Info; + +end Exp_CG; diff --git a/gcc/ada/exp_cg.ads b/gcc/ada/exp_cg.ads new file mode 100644 index 00000000000..5c2458d8408 --- /dev/null +++ b/gcc/ada/exp_cg.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines used to store and handle nodes required +-- to generate call graph information of dispatching calls. + +with Types; use Types; + +package Exp_CG is + + procedure Generate_CG_Output; + -- Generate in the standard output the information associated with tagged + -- types declaration and dispatching calls + + procedure Initialize; + -- Called at the start of compilation to initialize the table that stores + -- the tree nodes used by Generate_Output. This table is required because + -- the format of the output requires fully qualified names (and hence the + -- output must be generated after the source program has been compiled). + + procedure Register_CG_Node (N : Node_Id); + -- Register a dispatching call node or the defining entity of a tagged + -- type declaration + +end Exp_CG; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 3978e940146..111bc182fe7 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -469,9 +469,7 @@ package body Exp_Ch11 is Local_Expansion_Required := True; declare - L : constant Entity_Id := - Make_Defining_Identifier (Sloc (H), - Chars => New_Internal_Name ('L')); + L : constant Entity_Id := Make_Temporary (Sloc (H), 'L'); begin Set_Exception_Label (H, L); Add_Label_Declaration (L); @@ -646,9 +644,7 @@ package body Exp_Ch11 is declare -- L3 is the label to exit the HSS - L3_Dent : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L'); Labl_L3 : constant Node_Id := Make_Label (Loc, @@ -670,7 +666,8 @@ package body Exp_Ch11 is Rewrite (HSS, Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Blk_Stm))); + Statements => New_List (Blk_Stm), + End_Label => Relocate_Node (End_Label (HSS)))); -- Set block statement as analyzed, we don't want to actually call -- Analyze on this block, it would cause a recursion in exception @@ -745,13 +742,12 @@ package body Exp_Ch11 is Relmt := First_Elmt (Local_Raise_Statements (Handler)); while Present (Relmt) loop declare - Raise_S : constant Node_Id := Node (Relmt); - + Raise_S : constant Node_Id := Node (Relmt); + RLoc : constant Source_Ptr := Sloc (Raise_S); Name_L1 : constant Node_Id := New_Occurrence_Of (L1_Dent, Loc); - Goto_L1 : constant Node_Id := - Make_Goto_Statement (Loc, + Make_Goto_Statement (RLoc, Name => Name_L1); begin @@ -1555,15 +1551,6 @@ package body Exp_Ch11 is end if; end if; - -- There is no expansion needed for statement "raise <exception>;" when - -- compiling for the JVM since the JVM has a built-in exception - -- mechanism. However we need to keep the expansion for "raise;" - -- statements. See 4jexcept.ads for details. - - if Present (Name (N)) and then VM_Target /= No_VM then - return; - end if; - -- Case of name present, in this case we expand raise name to -- Raise_Exception (name'Identity, location_string); @@ -1686,7 +1673,7 @@ package body Exp_Ch11 is -- be referencing this entity by normal visibility methods. if No (Choice_Parameter (Ehand)) then - E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + E := Make_Temporary (Loc, 'E'); Set_Choice_Parameter (Ehand, E); Set_Ekind (E, E_Variable); Set_Etype (E, RTE (RE_Exception_Occurrence)); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 3b682cf04ae..d0004f473a0 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,6 +46,7 @@ with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; +with Validsw; use Validsw; package body Exp_Ch13 is @@ -346,6 +347,23 @@ package body Exp_Ch13 is Analyze (Decl, Suppress => All_Checks); Pop_Scope; + -- We treat generated equality specially, if validity checks are + -- enabled, in order to detect components default-initialized + -- with invalid values. + + elsif Nkind (Decl) = N_Subprogram_Body + and then Chars (Defining_Entity (Decl)) = Name_Op_Eq + and then Validity_Checks_On + and then Initialize_Scalars + then + declare + Save_Force : constant Boolean := Force_Validity_Checks; + begin + Force_Validity_Checks := True; + Analyze (Decl); + Force_Validity_Checks := Save_Force; + end; + else Analyze (Decl, Suppress => All_Checks); end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e36c8dcf24f..e2263f3ab8f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -504,7 +504,7 @@ package body Exp_Ch3 is -- And insert this declaration into the tree. The type of the -- discriminant is then reset to this more restricted subtype. - Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Tnn := Make_Temporary (Loc, 'T'); Insert_Action (Declaration_Node (Rtype), Make_Subtype_Declaration (Loc, @@ -1465,8 +1465,8 @@ package body Exp_Ch3 is if Has_Task (Full_Type) then if Restriction_Active (No_Task_Hierarchy) then - -- See comments in System.Tasking.Initialization.Init_RTS - -- for the value 3 (should be rtsfindable constant ???) + -- 3 is System.Tasking.Library_Task_Level + -- (should be rtsfindable constant ???) Append_To (Args, Make_Integer_Literal (Loc, 3)); @@ -2020,8 +2020,7 @@ package body Exp_Ch3 is if Has_Task (Rec_Type) then if Restriction_Active (No_Task_Hierarchy) then - -- See comments in System.Tasking.Initialization.Init_RTS - -- for the value 3. + -- 3 is System.Tasking.Library_Task_Level Append_To (Args, Make_Integer_Literal (Loc, 3)); else @@ -2115,10 +2114,7 @@ package body Exp_Ch3 is Spec_Node : Node_Id; begin - Func_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); - + Func_Id := Make_Temporary (Loc, 'F'); Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); -- Generate @@ -2246,9 +2242,7 @@ package body Exp_Ch3 is if Is_Tagged_Type (Rec_Type) and then not Is_CPP_Class (Rec_Type) then - Set_Tag := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Set_Tag := Make_Temporary (Loc, 'P'); Append_To (Parameters, Make_Parameter_Specification (Loc, @@ -2336,22 +2330,6 @@ package body Exp_Ch3 is New_Reference_To (Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); - -- Generate the SCIL node associated with the initialization of - -- the tag component. - - if Generate_SCIL then - declare - New_Node : Node_Id; - - begin - New_Node := - Make_SCIL_Tag_Init (Sloc (First (Init_Tags_List))); - Set_SCIL_Related_Node (New_Node, First (Init_Tags_List)); - Set_SCIL_Entity (New_Node, Rec_Type); - Prepend_To (Init_Tags_List, New_Node); - end; - end if; - -- Ada 2005 (AI-251): Initialize the secondary tags components -- located at fixed positions (tags whose position depends on -- variable size components are initialized later ---see below). @@ -3404,37 +3382,21 @@ package body Exp_Ch3 is Loc : constant Source_Ptr := Sloc (Typ); Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); - -- Build formal parameters of procedure - - Larray : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('A')); - Rarray : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('R')); - Left_Lo : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('L')); - Left_Hi : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('L')); - Right_Lo : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('R')); - Right_Hi : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('R')); - Rev : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars => New_Internal_Name ('D')); + Larray : constant Entity_Id := Make_Temporary (Loc, 'A'); + Rarray : constant Entity_Id := Make_Temporary (Loc, 'R'); + Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L'); + Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L'); + Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R'); + Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R'); + Rev : constant Entity_Id := Make_Temporary (Loc, 'D'); + -- Formal parameters of procedure + Proc_Name : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); - Lnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Rnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'L'); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'R'); -- Subscripts for left and right sides Decls : List_Id; @@ -4620,8 +4582,7 @@ package body Exp_Ch3 is Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), + Make_Temporary (Loc, 'D', Expr_N), Object_Definition => New_Occurrence_Of (Expr_Typ, Loc), Expression => @@ -4633,12 +4594,9 @@ package body Exp_Ch3 is Decl_2 := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - Subtype_Mark => - New_Occurrence_Of (Typ, Loc), - Name => + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => Unchecked_Convert_To (Typ, Make_Selected_Component (Loc, Prefix => @@ -4682,23 +4640,19 @@ package body Exp_Ch3 is Decl_1 := Make_Object_Declaration (Loc, Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - Object_Definition => + Make_Temporary (Loc, 'D', New_Expr), + Object_Definition => New_Occurrence_Of (Etype (Object_Definition (N)), Loc), - Expression => + Expression => Unchecked_Convert_To (Etype (Object_Definition (N)), New_Expr)); Decl_2 := Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), - Subtype_Mark => - New_Occurrence_Of (Typ, Loc), - Name => + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => Unchecked_Convert_To (Typ, Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), @@ -5972,8 +5926,8 @@ package body Exp_Ch3 is and then Has_Discriminants (Def_Id) then declare - Ctyp : constant Entity_Id := - Corresponding_Concurrent_Type (Def_Id); + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Def_Id); Conc_Discr : Entity_Id; Rec_Discr : Entity_Id; Temp : Entity_Id; @@ -5981,7 +5935,6 @@ package body Exp_Ch3 is begin Conc_Discr := First_Discriminant (Ctyp); Rec_Discr := First_Discriminant (Def_Id); - while Present (Conc_Discr) loop Temp := Discriminal (Conc_Discr); Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); @@ -6250,9 +6203,7 @@ package body Exp_Ch3 is -- See GNAT Pool packages in the Run-Time for more details - elsif Ekind (Def_Id) = E_Access_Type - or else Ekind (Def_Id) = E_General_Access_Type - then + elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then declare Loc : constant Source_Ptr := Sloc (N); Desig_Type : constant Entity_Id := Designated_Type (Def_Id); @@ -7868,12 +7819,11 @@ package body Exp_Ch3 is -- If a primitive is encountered that renames the predefined -- equality operator before reaching any explicit equality - -- primitive, then we still need to create a predefined - -- equality function, because calls to it can occur via - -- the renaming. A new name is created for the equality - -- to avoid conflicting with any user-defined equality. - -- (Note that this doesn't account for renamings of - -- equality nested within subpackages???) + -- primitive, then we still need to create a predefined equality + -- function, because calls to it can occur via the renaming. A new + -- name is created for the equality to avoid conflicting with any + -- user-defined equality. (Note that this doesn't account for + -- renamings of equality nested within subpackages???) if Is_Predefined_Eq_Renaming (Node (Prim)) then Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e66a063a4c1..7588ae3cc03 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -47,6 +47,7 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -58,13 +59,13 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with SCIL_LL; use SCIL_LL; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -322,10 +323,8 @@ package body Exp_Ch4 is if Nkind (Op1) = N_Op_Not then if Kind = N_Op_And then Proc_Name := RTE (RE_Vector_Nor); - elsif Kind = N_Op_Or then Proc_Name := RTE (RE_Vector_Nand); - else Proc_Name := RTE (RE_Vector_Xor); end if; @@ -333,14 +332,11 @@ package body Exp_Ch4 is else if Kind = N_Op_And then Proc_Name := RTE (RE_Vector_And); - elsif Kind = N_Op_Or then Proc_Name := RTE (RE_Vector_Or); - elsif Nkind (Op2) = N_Op_Not then Proc_Name := RTE (RE_Vector_Nxor); Arg2 := Right_Opnd (Op2); - else Proc_Name := RTE (RE_Vector_Xor); end if; @@ -351,15 +347,15 @@ package body Exp_Ch4 is Name => New_Occurrence_Of (Proc_Name, Loc), Parameter_Associations => New_List ( Target, - Make_Attribute_Reference (Loc, - Prefix => Arg1, - Attribute_Name => Name_Address), - Make_Attribute_Reference (Loc, - Prefix => Arg2, - Attribute_Name => Name_Address), - Make_Attribute_Reference (Loc, - Prefix => Op1, - Attribute_Name => Name_Length))); + Make_Attribute_Reference (Loc, + Prefix => Arg1, + Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => Arg2, + Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => Op1, + Attribute_Name => Name_Length))); end if; Rewrite (N, Call_Node); @@ -594,7 +590,7 @@ package body Exp_Ch4 is Set_Analyzed (Node); - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P', N); Insert_Action (N, Make_Object_Declaration (Loc, @@ -663,8 +659,7 @@ package body Exp_Ch4 is Remove_Side_Effects (Exp); end if; - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P', N); -- For a class wide allocation generate the following code: @@ -754,9 +749,7 @@ package body Exp_Ch4 is else declare - Def_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T'); New_Decl : Node_Id; begin @@ -833,8 +826,7 @@ package body Exp_Ch4 is New_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, - New_Internal_Name ('P')), + Defining_Identifier => Make_Temporary (Loc, 'P'), Object_Definition => New_Reference_To (PtrT, Loc), Expression => Unchecked_Convert_To (PtrT, New_Reference_To (Temp, Loc))); @@ -915,16 +907,13 @@ package body Exp_Ch4 is if Is_RTE (Apool, RE_SS_Pool) then declare - F : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); + F : constant Entity_Id := Make_Temporary (Loc, 'F'); begin Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => F, - Object_Definition => New_Reference_To (RTE - (RE_Finalizable_Ptr), Loc))); - + Object_Definition => + New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); Flist := New_Reference_To (F, Loc); Attach := Make_Integer_Literal (Loc, 1); end; @@ -990,8 +979,7 @@ package body Exp_Ch4 is end if; elsif Aggr_In_Place then - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P', N); Tmp_Node := Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -1075,9 +1063,7 @@ package body Exp_Ch4 is and then Is_Packed (T) then declare - ConstrT : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); Internal_Exp : constant Node_Id := Relocate_Node (Exp); begin Insert_Action (Exp, @@ -1597,8 +1583,7 @@ package body Exp_Ch4 is -- constrained types, then we can use the same index for both -- of the arrays. - An : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + An : constant Entity_Id := Make_Temporary (Loc, 'A'); Bn : Entity_Id; Index_T : Entity_Id; @@ -1615,9 +1600,7 @@ package body Exp_Ch4 is Index_T := Base_Type (Etype (Index)); if Need_Separate_Indexes then - Bn := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('B')); + Bn := Make_Temporary (Loc, 'B'); else Bn := An; end if; @@ -1804,7 +1787,7 @@ package body Exp_Ch4 is Defining_Identifier => B, Parameter_Type => New_Reference_To (Rtyp, Loc))); - Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Func_Name := Make_Temporary (Loc, 'E'); -- Build statement sequence for function @@ -2624,9 +2607,7 @@ package body Exp_Ch4 is Operands (NN) := Opnd; Is_Fixed_Length (NN) := False; - Var_Length (NN) := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Var_Length (NN) := Make_Temporary (Loc, 'L'); Append_To (Actions, Make_Object_Declaration (Loc, @@ -2673,9 +2654,7 @@ package body Exp_Ch4 is -- create an entity initialized to this length. else - Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Ent := Make_Temporary (Loc, 'L'); if Is_Fixed_Length (NN) then Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); @@ -2793,8 +2772,7 @@ package body Exp_Ch4 is end Get_Known_Bound; begin - Ent := - Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('L')); + Ent := Make_Temporary (Loc, 'L'); Append_To (Actions, Make_Object_Declaration (Loc, @@ -2848,11 +2826,12 @@ package body Exp_Ch4 is Insert_Actions (Cnode, Actions, Suppress => All_Checks); - -- Now we construct an array object with appropriate bounds + -- Now we construct an array object with appropriate bounds. We mark + -- the target as internal to prevent useless initialization when + -- Initialize_Scalars is enabled. - Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Ent := Make_Temporary (Loc, 'S'); + Set_Is_Internal (Ent); -- If the bound is statically known to be out of range, we do not want -- to abort, we want a warning and a runtime constraint error. Note that @@ -3176,9 +3155,10 @@ package body Exp_Ch4 is declare Decl : Node_Id; Outer_S : Entity_Id; - S : Entity_Id := Current_Scope; + S : Entity_Id; begin + S := Current_Scope; while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Function then Outer_S := Scope (S); @@ -3276,9 +3256,7 @@ package body Exp_Ch4 is ------------------------- procedure Rewrite_Coextension (N : Node_Id) is - Temp : constant Node_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('C')); + Temp : constant Node_Id := Make_Temporary (Loc, 'C'); -- Generate: -- Cnn : aliased Etyp; @@ -3431,9 +3409,7 @@ package body Exp_Ch4 is -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is -- marked as requiring static allocation. - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); - + Temp := Make_Temporary (Loc, 'T', Expression (Expression (N))); Desig := Subtype_Mark (Expression (N)); -- If context is constrained, use constrained subtype directly, @@ -3596,7 +3572,7 @@ package body Exp_Ch4 is if not Restriction_Active (No_Default_Initialization) then Init := Base_Init_Proc (T); Nod := N; - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Temp := Make_Temporary (Loc, 'P'); -- Construct argument list for the initialization routine call @@ -3668,9 +3644,11 @@ package body Exp_Ch4 is -- The designated type was an incomplete type, and the -- access type did not get expanded. Salvage it now. - pragma Assert (Present (Parent (Base_Type (PtrT)))); - Expand_N_Full_Type_Declaration - (Parent (Base_Type (PtrT))); + if not Restriction_Active (No_Task_Hierarchy) then + pragma Assert (Present (Parent (Base_Type (PtrT)))); + Expand_N_Full_Type_Declaration + (Parent (Base_Type (PtrT))); + end if; end if; -- If the context of the allocator is a declaration or an @@ -3713,16 +3691,22 @@ package body Exp_Ch4 is Decls := Build_Task_Image_Decls (Loc, T, T); end if; - Append_To (Args, - New_Reference_To - (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); + if Restriction_Active (No_Task_Hierarchy) then + -- 3 is System.Tasking.Library_Task_Level + Append_To (Args, Make_Integer_Literal (Loc, 3)); + else + Append_To (Args, + New_Reference_To + (Master_Id (Base_Type (Root_Type (PtrT))), Loc)); + end if; + Append_To (Args, Make_Identifier (Loc, Name_uChain)); Decl := Last (Decls); Append_To (Args, New_Occurrence_Of (Defining_Identifier (Decl), Loc)); - -- Has_Task is false, Decls not used + -- Has_Task is false, Decls not used else Decls := No_List; @@ -3906,11 +3890,142 @@ package body Exp_Ch4 is procedure Expand_N_And_Then (N : Node_Id) renames Expand_Short_Circuit_Operator; + ------------------------------ + -- Expand_N_Case_Expression -- + ------------------------------ + + procedure Expand_N_Case_Expression (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Cstmt : Node_Id; + Tnn : Entity_Id; + Pnn : Entity_Id; + Actions : List_Id; + Ttyp : Entity_Id; + Alt : Node_Id; + Fexp : Node_Id; + + begin + -- We expand + + -- case X is when A => AX, when B => BX ... + + -- to + + -- do + -- Tnn : typ; + -- case X is + -- when A => + -- Tnn := AX; + -- when B => + -- Tnn := BX; + -- ... + -- end case; + -- in Tnn end; + + -- However, this expansion is wrong for limited types, and also + -- wrong for unconstrained types (since the bounds may not be the + -- same in all branches). Furthermore it involves an extra copy + -- for large objects. So we take care of this by using the following + -- modified expansion for non-scalar types: + + -- do + -- type Pnn is access all typ; + -- Tnn : Pnn; + -- case X is + -- when A => + -- T := AX'Unrestricted_Access; + -- when B => + -- T := BX'Unrestricted_Access; + -- ... + -- end case; + -- in Tnn.all end; + + Cstmt := + Make_Case_Statement (Loc, + Expression => Expression (N), + Alternatives => New_List); + + Actions := New_List; + + -- Scalar case + + if Is_Scalar_Type (Typ) then + Ttyp := Typ; + + else + Pnn := Make_Temporary (Loc, 'P'); + Append_To (Actions, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Pnn, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Typ, Loc)))); + Ttyp := Pnn; + end if; + + Tnn := Make_Temporary (Loc, 'T'); + Append_To (Actions, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Ttyp, Loc))); + + -- Now process the alternatives + + Alt := First (Alternatives (N)); + while Present (Alt) loop + declare + Aexp : Node_Id := Expression (Alt); + Aloc : constant Source_Ptr := Sloc (Aexp); + + begin + if not Is_Scalar_Type (Typ) then + Aexp := + Make_Attribute_Reference (Aloc, + Prefix => Relocate_Node (Aexp), + Attribute_Name => Name_Unrestricted_Access); + end if; + + Append_To + (Alternatives (Cstmt), + Make_Case_Statement_Alternative (Sloc (Alt), + Discrete_Choices => Discrete_Choices (Alt), + Statements => New_List ( + Make_Assignment_Statement (Aloc, + Name => New_Occurrence_Of (Tnn, Loc), + Expression => Aexp)))); + end; + + Next (Alt); + end loop; + + Append_To (Actions, Cstmt); + + -- Construct and return final expression with actions + + if Is_Scalar_Type (Typ) then + Fexp := New_Occurrence_Of (Tnn, Loc); + else + Fexp := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Tnn, Loc)); + end if; + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => Fexp, + Actions => Actions)); + + Analyze_And_Resolve (N, Typ); + end Expand_N_Case_Expression; + ------------------------------------- -- Expand_N_Conditional_Expression -- ------------------------------------- - -- Expand into expression actions if then/else actions present + -- Deal with limited types and expression actions procedure Expand_N_Conditional_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -3919,33 +4034,68 @@ package body Exp_Ch4 is Elsex : constant Node_Id := Next (Thenx); Typ : constant Entity_Id := Etype (N); - Cnn : Entity_Id; - Decl : Node_Id; - New_If : Node_Id; - New_N : Node_Id; - P_Decl : Node_Id; + Cnn : Entity_Id; + Decl : Node_Id; + New_If : Node_Id; + New_N : Node_Id; + P_Decl : Node_Id; + Expr : Node_Id; + Actions : List_Id; begin - -- If either then or else actions are present, then given: + -- Fold at compile time if condition known. We have already folded + -- static conditional expressions, but it is possible to fold any + -- case in which the condition is known at compile time, even though + -- the result is non-static. + + -- Note that we don't do the fold of such cases in Sem_Elab because + -- it can cause infinite loops with the expander adding a conditional + -- expression, and Sem_Elab circuitry removing it repeatedly. + + if Compile_Time_Known_Value (Cond) then + if Is_True (Expr_Value (Cond)) then + Expr := Thenx; + Actions := Then_Actions (N); + else + Expr := Elsex; + Actions := Else_Actions (N); + end if; - -- if cond then then-expr else else-expr end + Remove (Expr); - -- we insert the following sequence of actions (using Insert_Actions): + if Present (Actions) then - -- Cnn : typ; - -- if cond then - -- <<then actions>> - -- Cnn := then-expr; - -- else - -- <<else actions>> - -- Cnn := else-expr - -- end if; + -- If we are not allowed to use Expression_With_Actions, just + -- skip the optimization, it is not critical for correctness. - -- and replace the conditional expression by a reference to Cnn + if not Use_Expression_With_Actions then + goto Skip_Optimization; + end if; - -- If the type is limited or unconstrained, the above expansion is - -- not legal, because it involves either an uninitialized object - -- or an illegal assignment. Instead, we generate: + Rewrite (N, + Make_Expression_With_Actions (Loc, + Expression => Relocate_Node (Expr), + Actions => Actions)); + Analyze_And_Resolve (N, Typ); + + else + Rewrite (N, Relocate_Node (Expr)); + end if; + + -- Note that the result is never static (legitimate cases of static + -- conditional expressions were folded in Sem_Eval). + + Set_Is_Static_Expression (N, False); + return; + end if; + + <<Skip_Optimization>> + + -- If the type is limited or unconstrained, we expand as follows to + -- avoid any possibility of improper copies. + + -- Note: it may be possible to avoid this special processing if the + -- back end uses its own mechanisms for handling by-reference types ??? -- type Ptr is access all Typ; -- Cnn : Ptr; @@ -3959,13 +4109,17 @@ package body Exp_Ch4 is -- and replace the conditional expresion by a reference to Cnn.all. - if Is_By_Reference_Type (Typ) then + -- This special case can be skipped if the back end handles limited + -- types properly and ensures that no incorrect copies are made. + + if Is_By_Reference_Type (Typ) + and then not Back_End_Handles_Limited_Types + then Cnn := Make_Temporary (Loc, 'C', N); P_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('A')), + Defining_Identifier => Make_Temporary (Loc, 'A'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -4008,40 +4162,84 @@ package body Exp_Ch4 is -- associated with either branch. elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then - Cnn := Make_Temporary (Loc, 'C', N); - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Cnn, - Object_Definition => New_Occurrence_Of (Typ, Loc)); + -- We have two approaches to handling this. If we are allowed to use + -- N_Expression_With_Actions, then we can just wrap the actions into + -- the appropriate expression. + + if Use_Expression_With_Actions then + if Present (Then_Actions (N)) then + Rewrite (Thenx, + Make_Expression_With_Actions (Sloc (Thenx), + Actions => Then_Actions (N), + Expression => Relocate_Node (Thenx))); + Set_Then_Actions (N, No_List); + Analyze_And_Resolve (Thenx, Typ); + end if; - New_If := - Make_Implicit_If_Statement (N, - Condition => Relocate_Node (Cond), + if Present (Else_Actions (N)) then + Rewrite (Elsex, + Make_Expression_With_Actions (Sloc (Elsex), + Actions => Else_Actions (N), + Expression => Relocate_Node (Elsex))); + Set_Else_Actions (N, No_List); + Analyze_And_Resolve (Elsex, Typ); + end if; - Then_Statements => New_List ( - Make_Assignment_Statement (Sloc (Thenx), - Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), - Expression => Relocate_Node (Thenx))), + return; - Else_Statements => New_List ( - Make_Assignment_Statement (Sloc (Elsex), - Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), - Expression => Relocate_Node (Elsex)))); + -- if we can't use N_Expression_With_Actions nodes, then we insert + -- the following sequence of actions (using Insert_Actions): - Set_Assignment_OK (Name (First (Then_Statements (New_If)))); - Set_Assignment_OK (Name (First (Else_Statements (New_If)))); + -- Cnn : typ; + -- if cond then + -- <<then actions>> + -- Cnn := then-expr; + -- else + -- <<else actions>> + -- Cnn := else-expr + -- end if; - New_N := New_Occurrence_Of (Cnn, Loc); + -- and replace the conditional expression by a reference to Cnn - else - -- No expansion needed, gigi handles it like a C conditional - -- expression. + else + Cnn := Make_Temporary (Loc, 'C', N); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + New_If := + Make_Implicit_If_Statement (N, + Condition => Relocate_Node (Cond), + + Then_Statements => New_List ( + Make_Assignment_Statement (Sloc (Thenx), + Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), + Expression => Relocate_Node (Thenx))), + + Else_Statements => New_List ( + Make_Assignment_Statement (Sloc (Elsex), + Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), + Expression => Relocate_Node (Elsex)))); + + Set_Assignment_OK (Name (First (Then_Statements (New_If)))); + Set_Assignment_OK (Name (First (Else_Statements (New_If)))); + + New_N := New_Occurrence_Of (Cnn, Loc); + end if; + -- If no actions then no expansion needed, gigi will handle it using + -- the same approach as a C conditional expression. + + else return; end if; - -- Move the SLOC of the parent If statement to the newly created one and + -- Fall through here for either the limited expansion, or the case of + -- inserting actions for non-limited types. In both these cases, we must + -- move the SLOC of the parent If statement to the newly created one and -- change it to the SLOC of the expression which, after expansion, will -- correspond to what is being evaluated. @@ -4172,14 +4370,14 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Rtyp); Error_Msg_N ("?explicit membership test may be optimized away", N); - Error_Msg_N ("\?use ''Valid attribute instead", N); + Error_Msg_N -- CODEFIX + ("\?use ''Valid attribute instead", N); return; end Substitute_Valid_Check; -- Start of processing for Expand_N_In begin - if Present (Alternatives (N)) then Remove_Side_Effects (Lop); Expand_Set_Membership; @@ -4188,9 +4386,12 @@ package body Exp_Ch4 is -- Check case of explicit test for an expression in range of its -- subtype. This is suspicious usage and we replace it with a 'Valid - -- test and give a warning. + -- test and give a warning. For floating point types however, this is a + -- standard way to check for finite numbers, and using 'Valid vould + -- typically be a pessimization. if Is_Scalar_Type (Etype (Lop)) + and then not Is_Floating_Point_Type (Etype (Lop)) and then Nkind (Rop) in N_Has_Entity and then Etype (Lop) = Entity (Rop) and then Comes_From_Source (N) @@ -4227,9 +4428,9 @@ package body Exp_Ch4 is and then Comes_From_Source (N) and then not In_Instance; -- This must be true for any of the optimization warnings, we - -- clearly want to give them only for source with the flag on. - -- We also skip these warnings in an instance since it may be - -- the case that different instantiations have different ranges. + -- clearly want to give them only for source with the flag on. We + -- also skip these warnings in an instance since it may be the + -- case that different instantiations have different ranges. Warn2 : constant Boolean := Warn1 @@ -4238,8 +4439,8 @@ package body Exp_Ch4 is -- For the case where only one bound warning is elided, we also -- insist on an explicit range and an integer type. The reason is -- that the use of enumeration ranges including an end point is - -- common, as is the use of a subtype name, one of whose bounds - -- is the same as the type of the expression. + -- common, as is the use of a subtype name, one of whose bounds is + -- the same as the type of the expression. begin -- If test is explicit x'first .. x'last, replace by valid check @@ -4284,8 +4485,8 @@ package body Exp_Ch4 is return; end if; - -- If we have an explicit range, do a bit of optimization based - -- on range analysis (we may be able to kill one or both checks). + -- If we have an explicit range, do a bit of optimization based on + -- range analysis (we may be able to kill one or both checks). Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False); Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False); @@ -4300,8 +4501,7 @@ package body Exp_Ch4 is Error_Msg_N ("\?value is known to be out of range", N); end if; - Rewrite (N, - New_Reference_To (Standard_False, Loc)); + Rewrite (N, New_Reference_To (Standard_False, Loc)); Analyze_And_Resolve (N, Rtyp); Set_Is_Static_Expression (N, Static); @@ -4316,8 +4516,7 @@ package body Exp_Ch4 is Error_Msg_N ("\?value is known to be in range", N); end if; - Rewrite (N, - New_Reference_To (Standard_True, Loc)); + Rewrite (N, New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); Set_Is_Static_Expression (N, Static); @@ -4431,11 +4630,8 @@ package body Exp_Ch4 is -- Update decoration of relocated node referenced by the -- SCIL node. - if Generate_SCIL - and then Present (SCIL_Node) - then - Set_SCIL_Related_Node (SCIL_Node, N); - Insert_Action (N, SCIL_Node); + if Generate_SCIL and then Present (SCIL_Node) then + Set_SCIL_Node (N, SCIL_Node); end if; end if; @@ -4474,12 +4670,10 @@ package body Exp_Ch4 is Make_Raise_Program_Error (Loc, Reason => PE_Unchecked_Union_Restriction)); - -- Prevent Gigi from generating incorrect code by rewriting - -- the test as a standard False. - - Rewrite (N, - New_Occurrence_Of (Standard_False, Loc)); + -- Prevent Gigi from generating incorrect code by rewriting the + -- test as False. + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); return; end if; @@ -4490,8 +4684,7 @@ package body Exp_Ch4 is end if; if not Is_Constrained (Typ) then - Rewrite (N, - New_Reference_To (Standard_True, Loc)); + Rewrite (N, New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); -- For the constrained array case, we have to check the subscripts @@ -4499,19 +4692,18 @@ package body Exp_Ch4 is -- must match in any case). elsif Is_Array_Type (Typ) then - Check_Subscripts : declare - function Construct_Attribute_Reference + function Build_Attribute_Reference (E : Node_Id; Nam : Name_Id; Dim : Nat) return Node_Id; - -- Build attribute reference E'Nam(Dim) + -- Build attribute reference E'Nam (Dim) - ----------------------------------- - -- Construct_Attribute_Reference -- - ----------------------------------- + ------------------------------- + -- Build_Attribute_Reference -- + ------------------------------- - function Construct_Attribute_Reference + function Build_Attribute_Reference (E : Node_Id; Nam : Name_Id; Dim : Nat) return Node_Id @@ -4519,11 +4711,11 @@ package body Exp_Ch4 is begin return Make_Attribute_Reference (Loc, - Prefix => E, + Prefix => E, Attribute_Name => Nam, - Expressions => New_List ( + Expressions => New_List ( Make_Integer_Literal (Loc, Dim))); - end Construct_Attribute_Reference; + end Build_Attribute_Reference; -- Start of processing for Check_Subscripts @@ -4532,21 +4724,21 @@ package body Exp_Ch4 is Evolve_And_Then (Cond, Make_Op_Eq (Loc, Left_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (Duplicate_Subexpr_No_Checks (Obj), Name_First, J), Right_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (New_Occurrence_Of (Typ, Loc), Name_First, J))); Evolve_And_Then (Cond, Make_Op_Eq (Loc, Left_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (Duplicate_Subexpr_No_Checks (Obj), Name_Last, J), Right_Opnd => - Construct_Attribute_Reference + Build_Attribute_Reference (New_Occurrence_Of (Typ, Loc), Name_Last, J))); end loop; @@ -4693,7 +4885,7 @@ package body Exp_Ch4 is -- The second expression in a 'Read attribute reference - -- The prefix of an address or size attribute reference + -- The prefix of an address or bit or size attribute reference -- The following circuit detects these exceptions @@ -4717,6 +4909,8 @@ package body Exp_Ch4 is elsif Nkind (Parnt) = N_Attribute_Reference and then (Attribute_Name (Parnt) = Name_Address or else + Attribute_Name (Parnt) = Name_Bit + or else Attribute_Name (Parnt) = Name_Size) and then Prefix (Parnt) = Child then @@ -5881,8 +6075,7 @@ package body Exp_Ch4 is -- En * En else -- Expv = 4 - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Temp := Make_Temporary (Loc, 'E', Base); Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, @@ -6656,7 +6849,7 @@ package body Exp_Ch4 is --------------------- -- If the argument is other than a Boolean array type, there is no special - -- expansion required. + -- expansion required, except for VMS operations on signed integers. -- For the packed case, we call the special routine in Exp_Pakd, except -- that if the component size is greater than one, we use the standard @@ -6706,6 +6899,49 @@ package body Exp_Ch4 is return; end if; + -- For the VMS "not" on signed integer types, use conversion to and + -- from a predefined modular type. + + if Is_VMS_Operator (Entity (N)) then + declare + Rtyp : Entity_Id; + Utyp : Entity_Id; + + begin + -- If this is a derived type, retrieve original VMS type so that + -- the proper sized type is used for intermediate values. + + if Is_Derived_Type (Typ) then + Rtyp := First_Subtype (Etype (Typ)); + else + Rtyp := Typ; + end if; + + -- The proper unsigned type must have a size compatible with + -- the operand, to prevent misalignment.. + + if RM_Size (Rtyp) <= 8 then + Utyp := RTE (RE_Unsigned_8); + + elsif RM_Size (Rtyp) <= 16 then + Utyp := RTE (RE_Unsigned_16); + + elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then + Utyp := RTE (RE_Unsigned_32); + + else + Utyp := RTE (RE_Long_Long_Unsigned); + end if; + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_Op_Not (Loc, + Unchecked_Convert_To (Utyp, Right_Opnd (N))))); + Analyze_And_Resolve (N, Typ); + return; + end; + end if; + -- Only array types need any other processing if not Is_Array_Type (Typ) then @@ -6810,7 +7046,7 @@ package body Exp_Ch4 is Name => B_J, Expression => Make_Op_Not (Loc, A_J)))); - Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); + Func_Name := Make_Temporary (Loc, 'N'); Set_Is_Inlined (Func_Name); Insert_Action (N, @@ -7421,6 +7657,7 @@ package body Exp_Ch4 is procedure Make_Temporary_For_Slice is Decl : Node_Id; Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N); + begin Decl := Make_Object_Declaration (Loc, @@ -7556,7 +7793,6 @@ package body Exp_Ch4 is Cons : List_Id; begin - -- Nothing else to do if no change of representation if Same_Representation (Operand_Type, Target_Type) then @@ -7645,7 +7881,7 @@ package body Exp_Ch4 is Constraints => Cons)); end if; - Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Temp := Make_Temporary (Loc, 'C'); Decl := Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -7807,9 +8043,7 @@ package body Exp_Ch4 is Enable_Overflow_Check (Conv); end if; - Tnn := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Tnn := Make_Temporary (Loc, 'T', Conv); Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, @@ -8040,15 +8274,13 @@ package body Exp_Ch4 is -- renaming, since this is an error situation which will be caught by -- Sem_Ch8, and the expansion can interfere with this error check. - if Is_Access_Type (Target_Type) - and then Is_Renamed_Object (N) - then + if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then return; end if; -- Otherwise, proceed with processing tagged conversion - declare + Tagged_Conversion : declare Actual_Op_Typ : Entity_Id; Actual_Targ_Typ : Entity_Id; Make_Conversion : Boolean := False; @@ -8103,7 +8335,7 @@ package body Exp_Ch4 is Reason => CE_Tag_Check_Failed)); end Make_Tag_Check; - -- Start of processing + -- Start of processing for Tagged_Conversion begin if Is_Access_Type (Target_Type) then @@ -8200,7 +8432,7 @@ package body Exp_Ch4 is end; end if; end if; - end; + end Tagged_Conversion; -- Case of other access type conversions @@ -8237,9 +8469,9 @@ package body Exp_Ch4 is 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) + -- 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 @@ -8293,7 +8525,7 @@ package body Exp_Ch4 is -- 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 + -- on targets with only 64-bit floats. -- The above comment seems obsoleted by Apply_Float_Conversion_Check -- Can this code be removed ??? @@ -8376,7 +8608,7 @@ package body Exp_Ch4 is elsif Is_Enumeration_Type (Target_Type) then -- Special processing is required if there is a change of - -- representation (from enumeration representation clauses) + -- representation (from enumeration representation clauses). if not Same_Representation (Target_Type, Operand_Type) then @@ -8402,9 +8634,8 @@ package body Exp_Ch4 is end if; -- At this stage, either the conversion node has been transformed into - -- some other equivalent expression, or left as a conversion that can - -- be handled by Gigi. The conversions that Gigi can handle are the - -- following: + -- some other equivalent expression, or left as a conversion that can be + -- handled by Gigi, in the following cases: -- Conversions with no change of representation or type @@ -8457,7 +8688,7 @@ package body Exp_Ch4 is end if; -- Reset overflow flag, since the range check will include - -- dealing with possible overflow, and generate the check If + -- 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. @@ -8488,16 +8719,15 @@ package body Exp_Ch4 is -- Expand_N_Unchecked_Expression -- ----------------------------------- - -- Remove the unchecked expression node from the tree. It's job was simply + -- Remove the unchecked expression node from the tree. Its job was simply -- to make sure that its constituent expression was handled with checks -- off, and now that that is done, we can remove it from the tree, and - -- indeed must, since gigi does not expect to see these nodes. + -- indeed must, since Gigi does not expect to see these nodes. procedure Expand_N_Unchecked_Expression (N : Node_Id) is Exp : constant Node_Id := Expression (N); - begin - Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp)); + Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp)); Rewrite (N, Exp); end Expand_N_Unchecked_Expression; @@ -8516,9 +8746,12 @@ package body Exp_Ch4 is begin -- Nothing at all to do if conversion is to the identical type so remove -- the conversion completely, it is useless, except that it may carry - -- an Assignment_OK indication which must be proprgated to the operand. + -- an Assignment_OK indication which must be propagated to the operand. if Operand_Type = Target_Type then + + -- Code duplicates Expand_N_Unchecked_Expression above, factor??? + if Assignment_OK (N) then Set_Assignment_OK (Operand); end if; @@ -8676,7 +8909,6 @@ package body Exp_Ch4 is Result := New_Reference_To (Standard_True, Loc); C := Suitable_Element (First_Entity (Typ)); - while Present (C) loop declare New_Lhs : Node_Id; @@ -8730,22 +8962,44 @@ package body Exp_Ch4 is -- Expand_Short_Circuit_Operator -- ----------------------------------- - -- Expand into conditional expression if Actions present, and also deal - -- with optimizing case of arguments being True or False. + -- Deal with special expansion if actions are present for the right operand + -- and deal with optimizing case of arguments being True or False. We also + -- deal with the special case of non-standard boolean values. procedure Expand_Short_Circuit_Operator (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); - Kind : constant Node_Kind := Nkind (N); Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); + LocR : constant Source_Ptr := Sloc (Right); Actlist : List_Id; Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else; Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value); -- If Left = Shortcut_Value then Right need not be evaluated - Expr_If_Left_True, Expr_If_Left_False : Node_Id; + function Make_Test_Expr (Opnd : Node_Id) return Node_Id; + -- For Opnd a boolean expression, return a Boolean expression equivalent + -- to Opnd /= Shortcut_Value. + + -------------------- + -- Make_Test_Expr -- + -------------------- + + function Make_Test_Expr (Opnd : Node_Id) return Node_Id is + begin + if Shortcut_Value then + return Make_Op_Not (Sloc (Opnd), Opnd); + else + return Opnd; + end if; + end Make_Test_Expr; + + Op_Var : Entity_Id; + -- Entity for a temporary variable holding the value of the operator, + -- used for expansion in the case where actions are present. + + -- Start of processing for Expand_Short_Circuit_Operator begin -- Deal with non-standard booleans @@ -8759,6 +9013,13 @@ package body Exp_Ch4 is -- Check for cases where left argument is known to be True or False if Compile_Time_Known_Value (Left) then + + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Left) then + Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True); + end if; + -- Rewrite True AND THEN Right / False OR ELSE Right to Right. -- Any actions associated with Right will be executed unconditionally -- and can thus be inserted into the tree unconditionally. @@ -8784,58 +9045,85 @@ package body Exp_Ch4 is return; end if; - -- If Actions are present, we expand + -- If Actions are present for the right operand, we have to do some + -- special processing. We can't just let these actions filter back into + -- code preceding the short circuit (which is what would have happened + -- if we had not trapped them in the short-circuit form), since they + -- must only be executed if the right operand of the short circuit is + -- executed and not otherwise. - -- left AND THEN right - -- left OR ELSE right + -- the temporary variable C. - -- into + if Present (Actions (N)) then + Actlist := Actions (N); - -- if left then right else false end - -- if left then true else right end + -- The old approach is to expand: - -- with the actions for the right operand being transferred to the - -- approriate actions list of the conditional expression. This - -- conditional expression is then further expanded (and will eventually - -- disappear). + -- left AND THEN right - if Present (Actions (N)) then - Actlist := Actions (N); + -- into - if Kind = N_And_Then then - Expr_If_Left_True := Right; - Expr_If_Left_False := New_Occurrence_Of (Standard_False, Loc); + -- C : Boolean := False; + -- IF left THEN + -- Actions; + -- IF right THEN + -- C := True; + -- END IF; + -- END IF; - else - Expr_If_Left_True := New_Occurrence_Of (Standard_True, Loc); - Expr_If_Left_False := Right; - end if; + -- and finally rewrite the operator into a reference to C. Similarly + -- for left OR ELSE right, with negated values. Note that this + -- rewrite causes some difficulties for coverage analysis because + -- of the introduction of the new variable C, which obscures the + -- structure of the test. - Rewrite (N, - Make_Conditional_Expression (Loc, - Expressions => New_List ( - Left, - Expr_If_Left_True, - Expr_If_Left_False))); - - -- If the right part of an AND THEN is a function call then it can - -- be part of the expansion of the predefined equality operator of a - -- tagged type and we may need to adjust its SCIL dispatching node. - - if Generate_SCIL - and then Kind = N_And_Then - and then Nkind (Right) = N_Function_Call - then - Adjust_SCIL_Node (N, Right); - end if; + -- We use this "old approach" if use of N_Expression_With_Actions + -- is False (see description in Opt of when this is or is not set). + + if not Use_Expression_With_Actions then + Op_Var := Make_Temporary (Loc, 'C', Related_Node => N); + + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => + Op_Var, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Shortcut_Ent, Loc))); + + Append_To (Actlist, + Make_Implicit_If_Statement (Right, + Condition => Make_Test_Expr (Right), + Then_Statements => New_List ( + Make_Assignment_Statement (LocR, + Name => New_Occurrence_Of (Op_Var, LocR), + Expression => + New_Occurrence_Of + (Boolean_Literals (not Shortcut_Value), LocR))))); + + Insert_Action (N, + Make_Implicit_If_Statement (Left, + Condition => Make_Test_Expr (Left), + Then_Statements => Actlist)); + + Rewrite (N, New_Occurrence_Of (Op_Var, Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + + -- The new approach, activated for now by the use of debug flag + -- -gnatd.X is to use the new Expression_With_Actions node for the + -- right operand of the short-circuit form. This should solve the + -- traceability problems for coverage analysis. - if Kind = N_And_Then then - Set_Then_Actions (N, Actlist); else - Set_Else_Actions (N, Actlist); + Rewrite (Right, + Make_Expression_With_Actions (LocR, + Expression => Relocate_Node (Right), + Actions => Actlist)); + Set_Actions (N, No_List); + Analyze_And_Resolve (Right, Standard_Boolean); end if; - Analyze_And_Resolve (N, Standard_Boolean); Adjust_Result_Type (N, Typ); return; end if; @@ -8843,6 +9131,13 @@ package body Exp_Ch4 is -- No actions present, check for cases of right argument True/False if Compile_Time_Known_Value (Right) then + + -- Mark SCO for left condition as compile time known + + if Generate_SCO and then Comes_From_Source (Right) then + Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True); + end if; + -- Change (Left and then True), (Left or else False) to Left. -- Note that we know there are no actions associated with the right -- operand, since we just checked for this case above. @@ -8929,7 +9224,7 @@ package body Exp_Ch4 is PtrT /= Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT))) then - Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Owner := Make_Temporary (Loc, 'J'); Insert_Action (N, Make_Full_Type_Declaration (Loc, Defining_Identifier => Owner, @@ -8953,7 +9248,7 @@ package body Exp_Ch4 is then Owner := Scope (Return_Applies_To (Scope (PtrT))); - -- Case of an access discriminant, or (Ada 2005), of an anonymous + -- Case of an access discriminant, or (Ada 2005) of an anonymous -- access component or anonymous access function result: find the -- final list associated with the scope of the type. (In the -- anonymous access component kind, a list controller will have @@ -9420,7 +9715,7 @@ package body Exp_Ch4 is -- if ... end if; -- end Gnnn; - Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); + Func_Name := Make_Temporary (Loc, 'G'); Func_Body := Make_Subprogram_Body (Loc, @@ -9548,8 +9843,7 @@ package body Exp_Ch4 is Defining_Identifier => B, Parameter_Type => New_Reference_To (Typ, Loc))); - Func_Name := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Func_Name := Make_Temporary (Loc, 'A'); Set_Is_Inlined (Func_Name); Func_Body := @@ -9601,7 +9895,7 @@ package body Exp_Ch4 is -- in the call to Compile_Time_Compare. If this call results in a -- clear result of always True or Always False, that's decisive and -- we are done. Otherwise we repeat the processing with Assume_Valid - -- set to True to generate additional warnings. We can stil that step + -- set to True to generate additional warnings. We can skip that step -- if Constant_Condition_Warnings is False. for AV in False .. True loop @@ -9690,9 +9984,9 @@ package body Exp_Ch4 is end if; -- If this is the second iteration (AV = True), and the original - -- node comes from source and we are not in an instance, then - -- give a warning if we know result would be True or False. Note - -- we know Constant_Condition_Warnings is set if we get here. + -- node comes from source and we are not in an instance, then give + -- a warning if we know result would be True or False. Note: we + -- know Constant_Condition_Warnings is set if we get here. elsif Comes_From_Source (Original_Node (N)) and then not In_Instance @@ -9710,9 +10004,9 @@ package body Exp_Ch4 is end; -- Skip second iteration if not warning on constant conditions or - -- if the first iteration already generated a warning of some kind - -- or if we are in any case assuming all values are valid (so that - -- the first iteration took care of the valid case). + -- if the first iteration already generated a warning of some kind or + -- if we are in any case assuming all values are valid (so that the + -- first iteration took care of the valid case). exit when not Constant_Condition_Warnings; exit when Warning_Generated; @@ -9779,7 +10073,7 @@ package body Exp_Ch4 is end if; end Is_Safe_Operand; - -- Start of processing for Is_Safe_In_Place_Array_Op + -- Start of processing for Is_Safe_In_Place_Array_Op begin -- Skip this processing if the component size is different from system @@ -9800,12 +10094,10 @@ package body Exp_Ch4 is elsif not Is_Unaliased (Lhs) then return False; + else Target := Entity (Lhs); - - return - Is_Safe_Operand (Op1) - and then Is_Safe_Operand (Op2); + return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2); end if; end Safe_In_Place_Array_Op; diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index fad8c15eea1..745ce294d6a 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,9 +31,10 @@ package Exp_Ch4 is procedure Expand_N_Allocator (N : Node_Id); procedure Expand_N_And_Then (N : Node_Id); + procedure Expand_N_Case_Expression (N : Node_Id); procedure Expand_N_Conditional_Expression (N : Node_Id); - procedure Expand_N_In (N : Node_Id); procedure Expand_N_Explicit_Dereference (N : Node_Id); + procedure Expand_N_In (N : Node_Id); procedure Expand_N_Indexed_Component (N : Node_Id); procedure Expand_N_Not_In (N : Node_Id); procedure Expand_N_Null (N : Node_Id); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 021afbf5282..71b58ae358e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -516,8 +516,7 @@ package body Exp_Ch5 is if Nkind (Rhs) = N_String_Literal then declare - Temp : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs); Decl : Node_Id; begin @@ -1028,13 +1027,8 @@ package body Exp_Ch5 is R_Index := First_Index (R_Type); for J in 1 .. Ndim loop - Lnn (J) := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Rnn (J) := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Lnn (J) := Make_Temporary (Loc, 'L'); + Rnn (J) := Make_Temporary (Loc, 'R'); L_Index_Type (J) := Etype (L_Index); R_Index_Type (J) := Etype (R_Index); @@ -1624,8 +1618,7 @@ package body Exp_Ch5 is BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs)); BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr); Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Make_Temporary (Loc, 'T', BPAR_Expr); begin -- Insert the post assignment first, because we want to copy the @@ -2848,8 +2841,7 @@ package body Exp_Ch5 is -- Create an access type designating the function's -- result subtype. - Ref_Type := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ref_Type := Make_Temporary (Loc, 'A'); Ptr_Type_Decl := Make_Full_Type_Declaration (Loc, @@ -2867,9 +2859,7 @@ package body Exp_Ch5 is -- from an implicit access value passed in by the caller -- or from the result of an allocator. - Alloc_Obj_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); Set_Etype (Alloc_Obj_Id, Ref_Type); Alloc_Obj_Decl := @@ -3854,8 +3844,7 @@ package body Exp_Ch5 is then declare Return_Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Make_Temporary (Loc, 'R', Exp); Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Return_Object_Entity, @@ -4009,13 +3998,9 @@ package body Exp_Ch5 is elsif CW_Or_Has_Controlled_Part (Utyp) then declare Loc : constant Source_Ptr := Sloc (N); - Temp : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - Acc_Typ : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); Alloc_Node : Node_Id; + Temp : Entity_Id; begin Set_Ekind (Acc_Typ, E_Access_Type); @@ -4031,13 +4016,15 @@ package body Exp_Ch5 is Expression => Make_Qualified_Expression (Loc, Subtype_Mark => New_Reference_To (Etype (Exp), Loc), - Expression => Relocate_Node (Exp))); + Expression => Relocate_Node (Exp))); -- We do not want discriminant checks on the declaration, -- given that it gets its value from the allocator. Set_No_Initialization (Alloc_Node); + Temp := Make_Temporary (Loc, 'R', Alloc_Node); + Insert_List_Before_And_Analyze (N, New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, @@ -4118,18 +4105,18 @@ package body Exp_Ch5 is else declare + ExpR : constant Node_Id := Relocate_Node (Exp); Result_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - Result_Exp : constant Node_Id := + Make_Temporary (Loc, 'R', ExpR); + Result_Exp : constant Node_Id := New_Reference_To (Result_Id, Loc); - Result_Obj : constant Node_Id := + Result_Obj : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Result_Id, Object_Definition => New_Reference_To (R_Type, Loc), Constant_Present => True, - Expression => Relocate_Node (Exp)); + Expression => ExpR); begin Set_Assignment_OK (Result_Obj); @@ -4205,24 +4192,24 @@ package body Exp_Ch5 is end; end if; - -- If we are returning an object that may not be bit-aligned, then - -- copy the value into a temporary first. This copy may need to expand - -- to a loop of component operations.. + -- If we are returning an object that may not be bit-aligned, then copy + -- the value into a temporary first. This copy may need to expand to a + -- loop of component operations. if Is_Possibly_Unaligned_Slice (Exp) or else Is_Possibly_Unaligned_Object (Exp) then declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); begin Insert_Action (Exp, Make_Object_Declaration (Loc, Defining_Identifier => Tnn, Constant_Present => True, Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => Relocate_Node (Exp)), - Suppress => All_Checks); + Expression => ExpR), + Suppress => All_Checks); Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); end; end if; @@ -4255,8 +4242,8 @@ package body Exp_Ch5 is else declare - Tnn : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); begin -- For a complex expression of an elementary type, capture @@ -4268,7 +4255,7 @@ package body Exp_Ch5 is Defining_Identifier => Tnn, Constant_Present => True, Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => Relocate_Node (Exp)), + Expression => ExpR), Suppress => All_Checks); Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); @@ -4281,7 +4268,7 @@ package body Exp_Ch5 is Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Tnn, Subtype_Mark => New_Occurrence_Of (R_Type, Loc), - Name => Relocate_Node (Exp)), + Name => ExpR), Suppress => All_Checks); Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); @@ -4421,8 +4408,7 @@ package body Exp_Ch5 is -- Save the Tag in a local variable Tag_Tmp if Save_Tag then - Tag_Tmp := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Tag_Tmp := Make_Temporary (Loc, 'A'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4461,8 +4447,7 @@ package body Exp_Ch5 is New_Reference_To (Controller_Component (T), Loc)); end if; - Prev_Tmp := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Prev_Tmp := Make_Temporary (Loc, 'B'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4477,9 +4462,7 @@ package body Exp_Ch5 is Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref), Selector_Name => Make_Identifier (Loc, Name_Prev)))); - Next_Tmp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')); + Next_Tmp := Make_Temporary (Loc, 'C'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4638,9 +4621,7 @@ package body Exp_Ch5 is Make_Integer_Literal (Loc, Intval => System_Storage_Unit)); - Range_Type := - Make_Defining_Identifier (Loc, - New_Internal_Name ('G')); + Range_Type := Make_Temporary (Loc, 'G'); Append_To (Res, Make_Subtype_Declaration (Loc, @@ -4659,9 +4640,7 @@ package body Exp_Ch5 is Append_To (Res, Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => @@ -4673,9 +4652,7 @@ package body Exp_Ch5 is -- type A is access S - Opaque_Type := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Opaque_Type := Make_Temporary (Loc, 'A'); Append_To (Res, Make_Full_Type_Declaration (Loc, @@ -4721,9 +4698,7 @@ package body Exp_Ch5 is -- Last index before hole: determined by position of the -- _Controller.Prev component. - Last_Before_Hole := - Make_Defining_Identifier (Loc, - New_Internal_Name ('L')); + Last_Before_Hole := Make_Temporary (Loc, 'L'); Append_To (Res, Make_Object_Declaration (Loc, @@ -4731,7 +4706,8 @@ package body Exp_Ch5 is Object_Definition => New_Occurrence_Of ( RTE (RE_Storage_Offset), Loc), Constant_Present => True, - Expression => Make_Op_Add (Loc, + Expression => + Make_Op_Add (Loc, Make_Attribute_Reference (Loc, Prefix => Prev_Ref, Attribute_Name => Name_Position), @@ -4756,9 +4732,7 @@ package body Exp_Ch5 is -- First index after hole - First_After_Hole := - Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); + First_After_Hole := Make_Temporary (Loc, 'F'); Append_To (Res, Make_Object_Declaration (Loc, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4ab2df7b878..9ddb278417c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -808,9 +808,7 @@ package body Exp_Ch6 is Elm := First_Elmt (Var_List); while Present (Elm) loop Var := Node (Elm); - Ent := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Ent := Make_Temporary (Loc, 'S'); Append_Elmt (Ent, Shad_List); -- Insert a declaration for this temporary at the start of the @@ -966,9 +964,7 @@ package body Exp_Ch6 is return; end if; - Temp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Temp := Make_Temporary (Loc, 'T', Actual); -- Use formal type for temp, unless formal type is an unconstrained -- array, in which case we don't have to worry about bounds checks, @@ -1220,9 +1216,7 @@ package body Exp_Ch6 is Reset_Packed_Prefix; - Temp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Temp := Make_Temporary (Loc, 'T', Actual); Incod := Relocate_Node (Actual); Outcod := New_Copy_Tree (Incod); @@ -1387,9 +1381,7 @@ package body Exp_Ch6 is return Entity (Actual); else - Var := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Var := Make_Temporary (Loc, 'T', Actual); N_Node := Make_Object_Renaming_Declaration (Loc, @@ -2676,9 +2668,7 @@ package body Exp_Ch6 is if Present (Inherited_From_Formal (Subp)) then Parent_Subp := Inherited_From_Formal (Subp); else - while Present (Alias (Parent_Subp)) loop - Parent_Subp := Alias (Parent_Subp); - end loop; + Parent_Subp := Ultimate_Alias (Parent_Subp); end if; -- The below setting of Entity is suspect, see F109-018 discussion??? @@ -2778,20 +2768,6 @@ package body Exp_Ch6 is Rewrite (Actual, Unchecked_Convert_To (Parent_Typ, Relocate_Node (Actual))); - - -- If the relocated node is a function call then it - -- can be part of the expansion of the predefined - -- equality operator of a tagged type and we may - -- need to adjust its SCIL dispatching node. - - if Generate_SCIL - and then Nkind (Actual) /= N_Null - and then Nkind (Expression (Actual)) - = N_Function_Call - then - Adjust_SCIL_Node (Actual, Expression (Actual)); - end if; - Analyze (Actual); Resolve (Actual, Parent_Typ); end if; @@ -2949,9 +2925,8 @@ package body Exp_Ch6 is return; end if; - if Ekind (Subp) = E_Function - or else Ekind (Subp) = E_Procedure - then + if Ekind_In (Subp, E_Function, E_Procedure) then + -- We perform two simple optimization on calls: -- a) replace calls to null procedures unconditionally; @@ -3104,12 +3079,14 @@ package body Exp_Ch6 is -- In Ada 2005, this may be an indirect call to an access parameter that -- is an access_to_subprogram. In that case the anonymous type has a -- scope that is a protected operation, but the call is a regular one. + -- In either case do not expand call if subprogram is eliminated. Scop := Scope (Subp); if Nkind (N) /= N_Entry_Call_Statement and then Is_Protected_Type (Scop) and then Ekind (Subp) /= E_Subprogram_Type + and then not Is_Eliminated (Subp) then -- If the call is an internal one, it is rewritten as a call to the -- corresponding unprotected subprogram. @@ -3304,6 +3281,9 @@ package body Exp_Ch6 is Temp : Entity_Id; Temp_Typ : Entity_Id; + Return_Object : Entity_Id := Empty; + -- Entity in declaration in an extended_return_statement + Is_Unc : constant Boolean := Is_Array_Type (Etype (Subp)) and then not Is_Constrained (Etype (Subp)); @@ -3312,8 +3292,8 @@ package body Exp_Ch6 is procedure Make_Exit_Label; -- Build declaration for exit label to be used in Return statements, - -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implcit - -- declaration). + -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit + -- declaration). Does nothing if Exit_Lab already set. function Process_Formals (N : Node_Id) return Traverse_Result; -- Replace occurrence of a formal with the corresponding actual, or the @@ -3343,20 +3323,15 @@ package body Exp_Ch6 is --------------------- procedure Make_Exit_Label is + Lab_Ent : Entity_Id; begin - -- Create exit label for subprogram if one does not exist yet - if No (Exit_Lab) then - Lab_Id := - Make_Identifier (Loc, - Chars => New_Internal_Name ('L')); - Set_Entity (Lab_Id, - Make_Defining_Identifier (Loc, Chars (Lab_Id))); + Lab_Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Lab_Ent, Loc); Exit_Lab := Make_Label (Loc, Lab_Id); - Lab_Decl := Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Lab_Id), + Defining_Identifier => Lab_Ent, Label_Construct => Exit_Lab); end if; end Make_Exit_Label; @@ -3402,6 +3377,22 @@ package body Exp_Ch6 is Rewrite (N, New_Copy (A)); end if; end if; + return Skip; + + elsif Is_Entity_Name (N) + and then Present (Return_Object) + and then Chars (N) = Chars (Return_Object) + then + -- Occurrence within an extended return statement. The return + -- object is local to the body been inlined, and thus the generic + -- copy is not analyzed yet, so we match by name, and replace it + -- with target of call. + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (Targ, Loc)); + else + Rewrite (N, New_Copy_Tree (Targ)); + end if; return Skip; @@ -3409,8 +3400,7 @@ package body Exp_Ch6 is if No (Expression (N)) then Make_Exit_Label; Rewrite (N, - Make_Goto_Statement (Loc, - Name => New_Copy (Lab_Id))); + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); else if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements @@ -3468,6 +3458,46 @@ package body Exp_Ch6 is return OK; + elsif Nkind (N) = N_Extended_Return_Statement then + + -- An extended return becomes a block whose first statement is + -- the assignment of the initial expression of the return object + -- to the target of the call itself. + + declare + Return_Decl : constant Entity_Id := + First (Return_Object_Declarations (N)); + Assign : Node_Id; + + begin + Return_Object := Defining_Identifier (Return_Decl); + + if Present (Expression (Return_Decl)) then + if Nkind (Targ) = N_Defining_Identifier then + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Expression (Return_Decl)); + else + Assign := + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Expression (Return_Decl)); + end if; + + Set_Assignment_OK (Name (Assign)); + Prepend (Assign, + Statements (Handled_Statement_Sequence (N))); + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N))); + + return OK; + end; + -- Remove pragma Unreferenced since it may refer to formals that -- are not visible in the inlined body, and in any case we will -- not be posting warnings on the inlined body so it is unneeded. @@ -3674,15 +3704,18 @@ package body Exp_Ch6 is if Nkind (Orig_Bod) = N_Defining_Identifier or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol then - -- Subprogram is a renaming_as_body. Calls appearing after the - -- renaming can be replaced with calls to the renamed entity - -- directly, because the subprograms are subtype conformant. If - -- the renamed subprogram is an inherited operation, we must redo - -- the expansion because implicit conversions may be needed. + -- Subprogram is renaming_as_body. Calls occurring after the renaming + -- can be replaced with calls to the renamed entity directly, because + -- the subprograms are subtype conformant. If the renamed subprogram + -- is an inherited operation, we must redo the expansion because + -- implicit conversions may be needed. Similarly, if the renamed + -- entity is inlined, expand the call for further optimizations. Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); - if Present (Alias (Orig_Bod)) then + if Present (Alias (Orig_Bod)) + or else Is_Inlined (Orig_Bod) + then Expand_Call (N); end if; @@ -3793,9 +3826,7 @@ package body Exp_Ch6 is end if; else - Temp := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')); + Temp := Make_Temporary (Loc, 'C'); -- If the actual for an in/in-out parameter is a view conversion, -- make it into an unchecked conversion, given that an untagged @@ -3880,11 +3911,15 @@ package body Exp_Ch6 is then Targ := Name (Parent (N)); + elsif Nkind (Parent (N)) = N_Object_Declaration + and then Is_Limited_Type (Etype (Subp)) + then + Targ := Defining_Identifier (Parent (N)); + else -- Replace call with temporary and create its declaration - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Temp := Make_Temporary (Loc, 'C'); Set_Is_Internal (Temp); -- For the unconstrained case, the generated temporary has the @@ -4354,9 +4389,7 @@ package body Exp_Ch6 is -- For a procedure, we add a return for all possible syntactic ends of -- the subprogram. - if Ekind (Spec_Id) = E_Procedure - or else Ekind (Spec_Id) = E_Generic_Procedure - then + if Ekind_In (Spec_Id, E_Procedure, E_Generic_Procedure) then Add_Return (Statements (H)); if Present (Exception_Handlers (H)) then @@ -4610,10 +4643,8 @@ package body Exp_Ch6 is -- define _object later on. declare - Decls : List_Id; - Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => - New_Internal_Name ('T')); + Decls : List_Id; + Obj_Ptr : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Decls := New_List ( @@ -4623,7 +4654,7 @@ package body Exp_Ch6 is Make_Access_To_Object_Definition (Loc, Subtype_Indication => New_Reference_To - (Corresponding_Record_Type (Scop), Loc)))); + (Corresponding_Record_Type (Scop), Loc)))); Insert_Actions (N, Decls); Insert_Actions (N, Freeze_Entity (Obj_Ptr, Sloc (N))); @@ -4719,14 +4750,21 @@ package body Exp_Ch6 is function Is_Build_In_Place_Function (E : Entity_Id) return Boolean is begin + -- This function is called from Expand_Subtype_From_Expr during + -- semantic analysis, even when expansion is off. In those cases + -- the build_in_place expansion will not take place. + + if not Expander_Active then + return False; + end if; + -- 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. - if Ekind (E) = E_Function - or else Ekind (E) = E_Generic_Function + if Ekind_In (E, E_Function, E_Generic_Function) or else (Ekind (E) = E_Subprogram_Type and then Etype (E) /= Standard_Void_Type) then @@ -5115,10 +5153,11 @@ package body Exp_Ch6 is Rewrite (Allocator, New_Allocator); -- Create a new access object and initialize it to the result of the - -- new uninitialized allocator. + -- new uninitialized allocator. Note: we do not use Allocator as the + -- Related_Node of Return_Obj_Access in call to Make_Temporary below + -- as this would create a sort of infinite "recursion". - Return_Obj_Access := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Return_Obj_Access := Make_Temporary (Loc, 'R'); Set_Etype (Return_Obj_Access, Acc_Type); Insert_Action (Allocator, @@ -5251,9 +5290,7 @@ package body Exp_Ch6 is -- Create a temporary object to hold the function result - Return_Obj_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Return_Obj_Id := Make_Temporary (Loc, 'R'); Set_Etype (Return_Obj_Id, Result_Subt); Return_Obj_Decl := @@ -5406,8 +5443,7 @@ package body Exp_Ch6 is -- Create an access type designating the function's result subtype - Ptr_Typ := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ptr_Typ := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -5422,7 +5458,7 @@ package body Exp_Ch6 is -- Finally, create an access object initialized to a reference to the -- function call. - Obj_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Obj_Id := Make_Temporary (Loc, 'R'); Set_Etype (Obj_Id, Ptr_Typ); Obj_Decl := @@ -5682,10 +5718,12 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc); - -- Create an access type designating the function's result subtype + -- Create an access type designating the function's result subtype. We + -- use the type of the original expression because it may be a call to + -- an inherited operation, which the expansion has replaced with the + -- parent operation that yields the parent type. - Ref_Type := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ref_Type := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -5694,7 +5732,7 @@ package body Exp_Ch6 is Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => - New_Reference_To (Result_Subt, Loc))); + New_Reference_To (Etype (Function_Call), Loc))); -- The access type and its accompanying object must be inserted after -- the object declaration in the constrained case, so that the function @@ -5712,15 +5750,13 @@ package body Exp_Ch6 is -- Finally, create an access object initialized to a reference to the -- function call. - Def_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - Set_Etype (Def_Id, Ref_Type); - New_Expr := Make_Reference (Loc, Prefix => Relocate_Node (Func_Call)); + Def_Id := Make_Temporary (Loc, 'R', New_Expr); + Set_Etype (Def_Id, Ref_Type); + Insert_After_And_Analyze (Ptr_Typ_Decl, Make_Object_Declaration (Loc, Defining_Identifier => Def_Id, @@ -5744,8 +5780,7 @@ package body Exp_Ch6 is Rewrite (Object_Decl, Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, - New_Internal_Name ('D')), + Defining_Identifier => Make_Temporary (Loc, 'D'), Access_Definition => Empty, Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), Name => Call_Deref)); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 880ae4e4cb9..308021472c2 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -54,7 +54,6 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Snames; use Snames; @@ -586,9 +585,7 @@ package body Exp_Ch7 is -- Here we generate the required loop else - Index := - Make_Defining_Identifier (Loc, New_Internal_Name ('J')); - + Index := Make_Temporary (Loc, 'J'); Append (New_Reference_To (Index, Loc), Index_List); return New_List ( @@ -1162,7 +1159,7 @@ package body Exp_Ch7 is and then not Sec_Stack_Needed_For_Return (Current_Scope) and then VM_Target = No_VM then - Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + Mark := Make_Temporary (Loc, 'M'); Append_To (New_Decls, Make_Object_Declaration (Loc, Defining_Identifier => Mark, @@ -1785,9 +1782,7 @@ package body Exp_Ch7 is end if; end if; - Id := - Make_Defining_Identifier (Flist_Loc, - Chars => New_Internal_Name ('F')); + Id := Make_Temporary (Flist_Loc, 'F'); end; Set_Finalization_Chain_Entity (S, Id); @@ -3438,7 +3433,7 @@ package body Exp_Ch7 is -- Fxxx : Finalizable_Ptr renames Lxxx.F; if Present (Finalization_Chain_Entity (S)) then - LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + LC := Make_Temporary (Loc, 'L'); -- Use the Sloc of the first declaration of N's containing list, to -- maintain monotonicity of source-line stepping during debugging. @@ -3570,15 +3565,6 @@ package body Exp_Ch7 is Expr : constant Node_Id := Relocate_Node (N); begin - -- If the relocated node is a function call then check if some SCIL - -- node references it and needs readjustment. - - if Generate_SCIL - and then Nkind (N) = N_Function_Call - then - Adjust_SCIL_Node (N, Expr); - end if; - Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => E, @@ -3626,15 +3612,6 @@ package body Exp_Ch7 is New_Statement : constant Node_Id := Relocate_Node (N); begin - -- If the relocated node is a procedure call then check if some SCIL - -- node references it and needs readjustment. - - if Generate_SCIL - and then Nkind (New_Statement) = N_Procedure_Call_Statement - then - Adjust_SCIL_Node (N, New_Statement); - end if; - Rewrite (N, Make_Transient_Block (Loc, New_Statement)); -- With the scope stack back to normal, we can call analyze on the diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index a7c5cd7ba5a..669f998c402 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -229,11 +229,11 @@ package Exp_Ch7 is procedure Store_Before_Actions_In_Scope (L : List_Id); -- Append the list L of actions to the end of the before-actions store in - -- the top of the scope stack + -- the top of the scope stack. procedure Store_After_Actions_In_Scope (L : List_Id); -- Append the list L of actions to the beginning of the after-actions store - -- in the top of the scope stack + -- in the top of the scope stack. procedure Wrap_Transient_Declaration (N : Node_Id); -- N is an object declaration. Expand the finalization calls after the diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ac439917107..2aec546e91a 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -128,6 +128,14 @@ package body Exp_Ch9 is -- Build a specification for a function implementing the protected entry -- barrier of the specified entry body. + function Build_Corresponding_Record + (N : Node_Id; + Ctyp : Node_Id; + Loc : Source_Ptr) return Node_Id; + -- Common to tasks and protected types. Copy discriminant specifications, + -- build record declaration. N is the type declaration, Ctyp is the + -- concurrent entity (task type or protected type). + function Build_Entry_Count_Expression (Concurrent_Type : Node_Id; Component_List : List_Id; @@ -1037,8 +1045,9 @@ package body Exp_Ch9 is -- record is "limited tagged". It is "limited" to reflect the underlying -- limitedness of the task or protected object that it represents, and -- ensuring for example that it is properly passed by reference. It is - -- "tagged" to give support to dispatching calls through interfaces (Ada - -- 2005: AI-345) + -- "tagged" to give support to dispatching calls through interfaces. We + -- propagate here the list of interfaces covered by the concurrent type + -- (Ada 2005: AI-345). return Make_Full_Type_Declaration (Loc, @@ -1051,6 +1060,7 @@ package body Exp_Ch9 is Component_Items => Cdecls), Tagged_Present => Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp), + Interface_List => Interface_List (N), Limited_Present => True)); end Build_Corresponding_Record; @@ -1168,8 +1178,7 @@ package body Exp_Ch9 is procedure Build_Entry_Family_Name (Id : Entity_Id) is Def : constant Node_Id := Discrete_Subtype_Definition (Parent (Id)); - L_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + L_Id : constant Entity_Id := Make_Temporary (Loc, 'L'); L_Stmts : constant List_Id := New_List; Val : Node_Id; @@ -1265,9 +1274,8 @@ package body Exp_Ch9 is Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => L_Id, - Discrete_Subtype_Definition => - Build_Range (Def))), + Defining_Identifier => L_Id, + Discrete_Subtype_Definition => Build_Range (Def))), Statements => L_Stmts, End_Label => Empty)); end Build_Entry_Family_Name; @@ -1411,7 +1419,7 @@ package body Exp_Ch9 is return Empty; end if; - Index := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + Index := Make_Temporary (Loc, 'I'); -- Step 1: Generate the declaration of the index variable: -- Inn : Protected_Entry_Index := 0; @@ -1428,10 +1436,8 @@ package body Exp_Ch9 is Append_To (B_Decls, Make_Object_Declaration (Loc, Defining_Identifier => Index, - Object_Definition => - New_Reference_To (RTE (Index_Typ), Loc), - Expression => - Make_Integer_Literal (Loc, 0))); + Object_Definition => New_Reference_To (RTE (Index_Typ), Loc), + Expression => Make_Integer_Literal (Loc, 0))); B_Stmts := New_List; @@ -1488,19 +1494,15 @@ package body Exp_Ch9 is -- Generate: -- type Ann is access all <actual-type> - Comp_Nam := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Comp_Nam := Make_Temporary (Loc, 'A'); Append_To (Decls, Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Comp_Nam, - Type_Definition => + Defining_Identifier => Comp_Nam, + Type_Definition => Make_Access_To_Object_Definition (Loc, - All_Present => - True, - Constant_Present => - Ekind (Formal) = E_In_Parameter, + All_Present => True, + Constant_Present => Ekind (Formal) = E_In_Parameter, Subtype_Indication => New_Reference_To (Etype (Actual), Loc)))); @@ -1525,8 +1527,7 @@ package body Exp_Ch9 is Next_Formal_With_Extras (Formal); end loop; - Rec_Nam := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Rec_Nam := Make_Temporary (Loc, 'P'); if Has_Comp then @@ -2141,7 +2142,6 @@ package body Exp_Ch9 is -- record type, so mark the spec accordingly. if Ekind (Subp_Id) = E_Function then - declare Res_Def : Node_Id; @@ -2397,12 +2397,10 @@ package body Exp_Ch9 is Add_Object_Pointer (Loc, Typ, Decls); while Present (Ent) loop - if Ekind (Ent) = E_Entry then Add_If_Clause (Make_Integer_Literal (Loc, 1)); elsif Ekind (Ent) = E_Entry_Family then - E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); @@ -3104,7 +3102,7 @@ package body Exp_Ch9 is if Nkind (Op_Spec) = N_Function_Specification then if Exc_Safe then - R := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + R := Make_Temporary (Loc, 'R'); Unprot_Call := Make_Object_Declaration (Loc, Defining_Identifier => R, @@ -3115,8 +3113,10 @@ package body Exp_Ch9 is Name => Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), Parameter_Associations => Uactuals)); - Return_Stmt := Make_Simple_Return_Statement (Loc, - Expression => New_Reference_To (R, Loc)); + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (R, Loc)); else Unprot_Call := Make_Simple_Return_Statement (Loc, @@ -3489,8 +3489,8 @@ package body Exp_Ch9 is and then Ada_Version >= Ada_05 then declare - Obj : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + ExpR : constant Node_Id := Relocate_Node (Concval); + Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); Decl : Node_Id; begin @@ -3498,7 +3498,7 @@ package body Exp_Ch9 is Make_Object_Declaration (Loc, Defining_Identifier => Obj, Object_Definition => New_Occurrence_Of (Conctyp, Loc), - Expression => Relocate_Node (Concval)); + Expression => ExpR); Set_Etype (Obj, Conctyp); Decls := New_List (Decl); Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); @@ -3568,11 +3568,9 @@ package body Exp_Ch9 is if Is_By_Copy_Type (Etype (Actual)) then N_Node := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('J')), - Aliased_Present => True, - Object_Definition => + Defining_Identifier => Make_Temporary (Loc, 'J'), + Aliased_Present => True, + Object_Definition => New_Reference_To (Etype (Formal), Loc)); -- Mark the object as not needing initialization since the @@ -3683,13 +3681,12 @@ package body Exp_Ch9 is -- Bnn : Communications_Block; - Comm_Name := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Comm_Name := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Comm_Name, - Object_Definition => + Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); -- Some additional statements for protected entry calls @@ -3941,16 +3938,13 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Chain : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uChain); - - Blkent : Entity_Id; + Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); Block : Node_Id; begin - Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - Block := Make_Block_Statement (Loc, - Identifier => New_Reference_To (Blkent, Loc), + Identifier => New_Reference_To (Blkent, Loc), Declarations => New_List ( -- _Chain : Activation_Chain; @@ -4006,12 +4000,10 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Chain : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uChain); - Blkent : Entity_Id; + Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); Block : Node_Id; begin - Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - Append_To (Init_Stmts, Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), @@ -4141,9 +4133,7 @@ package body Exp_Ch9 is Efam := First_Entity (Conctyp); while Present (Efam) loop if Ekind (Efam) = E_Entry_Family then - Efam_Type := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('F')); + Efam_Type := Make_Temporary (Loc, 'F'); declare Bas : Entity_Id := @@ -4158,9 +4148,7 @@ package body Exp_Ch9 is (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then - Bas := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('B')); + Bas := Make_Temporary (Loc, 'B'); Bas_Decl := Make_Subtype_Declaration (Loc, @@ -4397,20 +4385,19 @@ package body Exp_Ch9 is else declare Decl : Node_Id; - T_Self : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); T_Body : constant Node_Id := Parent (Corresponding_Body (Parent (Entity (N)))); begin - Decl := Make_Object_Declaration (Loc, - Defining_Identifier => T_Self, - Object_Definition => - New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Self), Loc))); + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => T_Self, + Object_Definition => + New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Self), Loc))); Prepend (Decl, Declarations (T_Body)); Analyze (Decl); Set_Scope (T_Self, Entity (N)); @@ -4707,25 +4694,28 @@ package body Exp_Ch9 is -- completes in the middle of the accept body. if Present (Handled_Statement_Sequence (N)) then - Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); - Set_Entity (Lab_Id, - Make_Defining_Identifier (Loc, Chars (Lab_Id))); - Lab := Make_Label (Loc, Lab_Id); - Ldecl := - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Lab_Id), - Label_Construct => Lab); - Append (Lab, Statements (Handled_Statement_Sequence (N))); - - Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); - Set_Entity (Lab_Id, - Make_Defining_Identifier (Loc, Chars (Lab_Id))); - Lab := Make_Label (Loc, Lab_Id); - Ldecl2 := - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Entity (Lab_Id), - Label_Construct => Lab); - Append (Lab, Statements (Handled_Statement_Sequence (N))); + declare + Ent : Entity_Id; + + begin + Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Ent, Loc); + Lab := Make_Label (Loc, Lab_Id); + Ldecl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Ent, + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + + Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Reference_To (Ent, Loc); + Lab := Make_Label (Loc, Lab_Id); + Ldecl2 := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Ent, + Label_Construct => Lab); + Append (Lab, Statements (Handled_Statement_Sequence (N))); + end; else Ldecl := Empty; @@ -4737,9 +4727,7 @@ package body Exp_Ch9 is if Is_List_Member (N) then if Present (Handled_Statement_Sequence (N)) then - Ann := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Ann := Make_Temporary (Loc, 'A'); Adecl := Make_Object_Declaration (Loc, @@ -4796,9 +4784,7 @@ package body Exp_Ch9 is -- label for requeue expansion must be declared. if N = Accept_Statement (Alt) then - Ann := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - + Ann := Make_Temporary (Loc, 'A'); Adecl := Make_Object_Declaration (Loc, Defining_Identifier => Ann, @@ -4911,10 +4897,8 @@ package body Exp_Ch9 is Comps : List_Id; T : constant Entity_Id := Defining_Identifier (N); D_T : constant Entity_Id := Designated_Type (T); - D_T2 : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('D')); - E_T : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('E')); + D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); + E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); P_List : constant List_Id := Build_Protected_Spec (N, RTE (RE_Address), D_T, False); Decl1 : Node_Id; @@ -4950,8 +4934,7 @@ package body Exp_Ch9 is Comps := New_List ( Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('P')), + Defining_Identifier => Make_Temporary (Loc, 'P'), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, @@ -4959,11 +4942,10 @@ package body Exp_Ch9 is New_Occurrence_Of (RTE (RE_Address), Loc))), Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Component_Definition => Make_Component_Definition (Loc, - Aliased_Present => False, + Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); Decl2 := @@ -5291,7 +5273,7 @@ package body Exp_Ch9 is -- Construct the block, using the declarations from the accept -- statement if any to initialize the declarations of the block. - Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Blkent := Make_Temporary (Loc, 'A'); Set_Ekind (Blkent, E_Block); Set_Etype (Blkent, Standard_Void_Type); Set_Scope (Blkent, Current_Scope); @@ -5676,7 +5658,7 @@ package body Exp_Ch9 is T : Entity_Id; -- Additional status flag begin - Blk_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Blk_Ent := Make_Temporary (Loc, 'A'); Ecall := Triggering_Statement (Trig); -- The arguments in the call may require dynamic allocation, and the @@ -5717,13 +5699,11 @@ package body Exp_Ch9 is -- Communication block processing, generate: -- Bnn : Communication_Block; - Bnn := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Bnn := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Bnn, - Object_Definition => + Defining_Identifier => Bnn, + Object_Definition => New_Reference_To (RTE (RE_Communication_Block), Loc))); -- Call kind processing, generate: @@ -5761,14 +5741,13 @@ package body Exp_Ch9 is S := Build_S (Loc, Decls); -- Additional status flag processing, generate: + -- Tnn : Boolean; - T := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); - + T := Make_Temporary (Loc, 'T'); Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - T, - Object_Definition => + Defining_Identifier => T, + Object_Definition => New_Reference_To (Standard_Boolean, Loc))); ------------------------------ @@ -5853,9 +5832,7 @@ package body Exp_Ch9 is -- _clean; -- end; - Cleanup_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - + Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); Cleanup_Block := Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); @@ -5868,9 +5845,7 @@ package body Exp_Ch9 is -- when Abort_Signal => Abort_Undefer; -- end; - Abort_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); - + Abort_Block_Ent := Make_Temporary (Loc, 'A'); ProtE_Stmts := New_List ( Make_Implicit_Label_Declaration (Loc, @@ -5985,9 +5960,7 @@ package body Exp_Ch9 is -- _clean; -- end; - Cleanup_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - + Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); Cleanup_Block := Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); @@ -6000,13 +5973,11 @@ package body Exp_Ch9 is -- when Abort_Signal => Abort_Undefer; -- end; - Abort_Block_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Abort_Block_Ent := Make_Temporary (Loc, 'A'); Append_To (TaskE_Stmts, Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => - Abort_Block_Ent)); + Defining_Identifier => Abort_Block_Ent)); Append_To (TaskE_Stmts, Build_Abort_Block @@ -6143,8 +6114,7 @@ package body Exp_Ch9 is -- Add a Delay_Block object to the parameter list of the delay -- procedure to form the parameter list of the Wait entry call. - Dblock_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Dblock_Ent := Make_Temporary (Loc, 'D'); Pdef := Entity (Name (Ecall)); @@ -7092,8 +7062,7 @@ package body Exp_Ch9 is -- Declare new access type and then append - Ctype := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ctype := Make_Temporary (Loc, 'A'); Decl := Make_Full_Type_Declaration (Loc, @@ -7120,8 +7089,7 @@ package body Exp_Ch9 is -- Create the Entry_Parameter_Record declaration - Rec_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Rec_Ent := Make_Temporary (Loc, 'P'); Decl := Make_Full_Type_Declaration (Loc, @@ -7137,8 +7105,7 @@ package body Exp_Ch9 is -- Construct and link in the corresponding access type - Acc_Ent := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Acc_Ent := Make_Temporary (Loc, 'A'); Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); @@ -7725,11 +7692,6 @@ package body Exp_Ch9 is Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Qualify_Entity_Names (N); -- If the type has discriminants, their occurrences in the declaration @@ -8751,8 +8713,7 @@ package body Exp_Ch9 is function Accept_Or_Raise return List_Id is Cond : Node_Id; Stats : List_Id; - J : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('J')); + J : constant Entity_Id := Make_Temporary (Loc, 'J'); begin -- We generate the following: @@ -9344,8 +9305,8 @@ package body Exp_Ch9 is -- Create Duration and Delay_Mode objects used for passing a delay -- value to RTS - D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); - M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + D := Make_Temporary (Loc, 'D'); + M := Make_Temporary (Loc, 'M'); declare Discr : Entity_Id; @@ -9990,11 +9951,6 @@ package body Exp_Ch9 is Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); - -- Ada 2005 (AI-345): Propagate the attribute that contains the list - -- of implemented interfaces. - - Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N)); - Rec_Ent := Defining_Identifier (Rec_Decl); Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); @@ -10579,7 +10535,7 @@ package body Exp_Ch9 is New_List (New_Copy (Expression (D_Stat)))); end if; - D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + D := Make_Temporary (Loc, 'D'); -- Generate: -- D : Duration; @@ -10591,7 +10547,7 @@ package body Exp_Ch9 is Object_Definition => New_Reference_To (Standard_Duration, Loc))); - M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); + M := Make_Temporary (Loc, 'M'); -- Generate: -- M : Integer := (0 | 1 | 2); @@ -11370,9 +11326,7 @@ package body Exp_Ch9 is if Is_Protected then declare - Prot_Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); Prot_Typ : RE_Id; begin @@ -11561,8 +11515,7 @@ package body Exp_Ch9 is High := Replace_Bound (High); Low := Replace_Bound (Low); - Index_Typ := - Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Index_Typ := Make_Temporary (Loc, 'J'); -- Generate: -- subtype Jnn is <Etype of Index> range Low .. High; @@ -11790,9 +11743,7 @@ package body Exp_Ch9 is -- Interrupt_Priority). else - Temp := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - + Temp := Make_Temporary (Loc, 'R', Prio); Append_To (L, Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -11800,7 +11751,7 @@ package body Exp_Ch9 is New_Occurrence_Of (RTE (RE_Any_Priority), Loc), Expression => Relocate_Node (Prio))); - Append_To (Args, New_Occurrence_Of (Temp, Loc)); + Append_To (Args, New_Occurrence_Of (Temp, Loc)); end if; end; @@ -12170,9 +12121,8 @@ package body Exp_Ch9 is -- Master parameter. This is a reference to the _Master parameter of -- the initialization procedure, except in the case of the pragma - -- Restrictions (No_Task_Hierarchy) where the value is fixed to 3. - -- See comments in System.Tasking.Initialization.Init_RTS for the - -- value 3. + -- Restrictions (No_Task_Hierarchy) where the value is fixed to 3 + -- (3 is System.Tasking.Library_Task_Level). if Restriction_Active (No_Task_Hierarchy) = False then Append_To (Args, Make_Identifier (Loc, Name_uMaster)); @@ -12380,8 +12330,7 @@ package body Exp_Ch9 is -- Generate: -- Jnn : aliased <formal-type> - Temp_Nam := - Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + Temp_Nam := Make_Temporary (Loc, 'J'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -12447,7 +12396,7 @@ package body Exp_Ch9 is -- <actual2>'reference; -- ...); - P := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + P := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Declaration (Loc, diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 22a27d6422e..80d870ad8a1 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -50,14 +50,6 @@ package Exp_Ch9 is -- Task_Id of the associated task as the parameter. The caller is -- responsible for analyzing and resolving the resulting tree. - function Build_Corresponding_Record - (N : Node_Id; - Ctyp : Node_Id; - Loc : Source_Ptr) return Node_Id; - -- Common to tasks and protected types. Copy discriminant specifications, - -- build record declaration. N is the type declaration, Ctyp is the - -- concurrent entity (task type or protected type). - function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id; -- Create the statements which populate the entry names array of a task or -- protected type. The statements are wrapped inside a block due to a local diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 42ef7e06ac9..7599a25dc73 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Atag; use Exp_Atag; with Exp_Ch7; use Exp_Ch7; +with Exp_CG; use Exp_CG; with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -59,6 +60,7 @@ 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; with Uintp; use Uintp; @@ -577,8 +579,9 @@ package body Exp_Disp is -- Local variables - New_Node : Node_Id; - SCIL_Node : Node_Id; + New_Node : Node_Id; + SCIL_Node : Node_Id; + SCIL_Related_Node : Node_Id := Call_Node; -- Start of processing for Expand_Dispatching_Call @@ -648,19 +651,6 @@ package body Exp_Disp is Typ := Non_Limited_View (Typ); end if; - -- Generate the SCIL node for this dispatching call. The SCIL node for a - -- dispatching call is inserted in the tree before the call is rewriten - -- and expanded because the SCIL node must be found by the SCIL backend - -- BEFORE the expanded nodes associated with the call node are found. - - if Generate_SCIL then - SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); - Set_SCIL_Related_Node (SCIL_Node, Call_Node); - Set_SCIL_Entity (SCIL_Node, Typ); - Set_SCIL_Target_Prim (SCIL_Node, Subp); - Insert_Action (Call_Node, SCIL_Node); - end if; - if not Is_Limited_Type (Typ) then Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq); end if; @@ -840,12 +830,16 @@ package body Exp_Disp is New_Call_Name := Unchecked_Convert_To (Subp_Ptr_Typ, New_Node); - -- Complete decoration of SCIL dispatching node. It must be done after - -- the new call name is built to reference the nodes that will see the - -- SCIL backend (because Build_Get_Prim_Op_Address generates an - -- unchecked type conversion which relocates the controlling tag node). + -- Generate the SCIL node for this dispatching call. Done now because + -- attribute SCIL_Controlling_Tag must be set after the new call name + -- is built to reference the nodes that will see the SCIL backend + -- (because Build_Get_Prim_Op_Address generates an unchecked type + -- conversion which relocates the controlling tag node). if Generate_SCIL then + SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); + Set_SCIL_Entity (SCIL_Node, Typ); + Set_SCIL_Target_Prim (SCIL_Node, Subp); -- Common case: the controlling tag is the tag of an object -- (for example, obj.tag) @@ -943,6 +937,8 @@ package body Exp_Disp is New_Reference_To (First_Tag_Component (Typ), Loc))), Right_Opnd => New_Call); + + SCIL_Related_Node := Right_Opnd (New_Call); end if; else @@ -952,8 +948,18 @@ package body Exp_Disp is Parameter_Associations => New_Params); end if; + -- Register the dispatching call in the call graph nodes table + + Register_CG_Node (Call_Node); + Rewrite (Call_Node, New_Call); + -- Associate the SCIL node of this dispatching call + + if Generate_SCIL then + Set_SCIL_Node (SCIL_Related_Node, SCIL_Node); + end if; + -- Suppress all checks during the analysis of the expanded code -- to avoid the generation of spurious warnings under ZFP run-time. @@ -1148,8 +1154,7 @@ package body Exp_Disp is New_Typ_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -1190,10 +1195,7 @@ package body Exp_Disp is Else_Statements => Stats)); end if; - Fent := - Make_Defining_Identifier (Loc, - New_Internal_Name ('F')); - + Fent := Make_Temporary (Loc, 'F'); Func := Make_Subprogram_Body (Loc, Specification => @@ -1464,10 +1466,15 @@ package body Exp_Disp is Thunk_Id := Empty; Thunk_Code := Empty; + -- No thunk needed if the primitive has been eliminated + + if Is_Eliminated (Ultimate_Alias (Prim)) then + return; + -- In case of primitives that are functions without formals and a -- controlling result there is no need to build the thunk. - if not Present (First_Formal (Target)) then + elsif not Present (First_Formal (Target)) then pragma Assert (Ekind (Target) = E_Function and then Has_Controlling_Result (Target)); return; @@ -1528,21 +1535,22 @@ package body Exp_Disp is Formal := First (Formals); while Present (Formal) loop - -- Handle concurrent types. + -- If the parent is a constrained discriminated type, then the + -- primitive operation will have been defined on a first subtype. + -- For proper matching with controlling type, use base type. if Ekind (Target_Formal) = E_In_Parameter and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type then - Ftyp := Directly_Designated_Type (Etype (Target_Formal)); + Ftyp := + Base_Type (Directly_Designated_Type (Etype (Target_Formal))); else - - -- if the parent is a constrained discriminated type. the - -- primitive operation will have been defined on a first subtype. - -- for proper matching with controlling type, use base type. - Ftyp := Base_Type (Etype (Target_Formal)); end if; + -- For concurrent types, the relevant information is found in the + -- Corresponding_Record_Type, rather than the type entity itself. + if Is_Concurrent_Type (Ftyp) then Ftyp := Corresponding_Record_Type (Ftyp); end if; @@ -1558,9 +1566,7 @@ package body Exp_Disp is Decl_2 := Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')), + Defining_Identifier => Make_Temporary (Loc, 'T'), Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, @@ -1585,9 +1591,7 @@ package body Exp_Disp is Decl_1 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), @@ -1637,8 +1641,7 @@ package body Exp_Disp is Decl_1 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Defining_Identifier => Make_Temporary (Loc, 'S'), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Storage_Offset), Loc), @@ -1657,11 +1660,11 @@ package body Exp_Disp is Decl_2 := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Constant_Present => True, - Object_Definition => New_Reference_To (RTE (RE_Addr_Ptr), Loc), - Expression => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Constant_Present => True, + Object_Definition => + New_Reference_To (RTE (RE_Addr_Ptr), Loc), + Expression => Unchecked_Convert_To (RTE (RE_Addr_Ptr), New_Reference_To (Defining_Identifier (Decl_1), Loc))); @@ -1669,7 +1672,7 @@ package body Exp_Disp is Append_To (Decl, Decl_1); Append_To (Decl, Decl_2); - -- Reference the new actual. Generate: + -- Reference the new actual, generate: -- Target_Formal (S2.all) Append_To (Actuals, @@ -1688,10 +1691,7 @@ package body Exp_Disp is Next (Formal); end loop; - Thunk_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - + Thunk_Id := Make_Temporary (Loc, 'T'); Set_Is_Thunk (Thunk_Id); -- Procedure case @@ -1774,7 +1774,7 @@ package body Exp_Disp is or else TSS_Name = TSS_Stream_Output or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize @@ -1816,7 +1816,7 @@ package body Exp_Disp is or else Chars (E) = Name_uAlignment or else (Chars (E) = Name_Op_Eq - and then Etype (First_Entity (E)) = Etype (Last_Entity (E))) + and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) or else Chars (E) = Name_uAssign or else TSS_Name = TSS_Deep_Adjust or else TSS_Name = TSS_Deep_Finalize @@ -1835,23 +1835,10 @@ package body Exp_Disp is function Is_Predefined_Dispatching_Alias (Prim : Entity_Id) return Boolean is - E : Entity_Id; - begin - if not Is_Predefined_Dispatching_Operation (Prim) + return not Is_Predefined_Dispatching_Operation (Prim) and then Present (Alias (Prim)) - then - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - if Is_Predefined_Dispatching_Operation (E) then - return True; - end if; - end if; - - return False; + and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim)); end Is_Predefined_Dispatching_Alias; --------------------------------------- @@ -1990,9 +1977,7 @@ package body Exp_Disp is -- Generate: -- Bnn : Communication_Block; - Com_Block := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Com_Block := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => @@ -2343,8 +2328,7 @@ package body Exp_Disp is -- where Bnn is the name of the communication block used in the -- call to Protected_Entry_Call. - Blk_Nam := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); - + Blk_Nam := Make_Temporary (Loc, 'B'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => @@ -3589,13 +3573,8 @@ package body Exp_Disp is Exporting_Table : constant Boolean := Building_Static_DT (Typ) and then Suffix_Index > 0; - Iface_DT : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - Name_Predef_Prims : constant Name_Id := New_Internal_Name ('R'); - Predef_Prims : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_Predef_Prims); + Iface_DT : constant Entity_Id := Make_Temporary (Loc, 'T'); + Predef_Prims : constant Entity_Id := Make_Temporary (Loc, 'R'); DT_Constr_List : List_Id; DT_Aggr_List : List_Id; Empty_DT : Boolean := False; @@ -3694,6 +3673,7 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then @@ -3702,11 +3682,8 @@ package body Exp_Disp is Alias (Prim); else - while Present (Alias (Prim)) loop - Prim := Alias (Prim); - end loop; - - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); + Expand_Interface_Thunk + (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code); if Present (Thunk_Id) then Append_To (Result, Thunk_Code); @@ -3744,10 +3721,8 @@ package body Exp_Disp is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), - Subtype_Indication => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => New_Reference_To (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); @@ -3875,12 +3850,7 @@ package body Exp_Disp is (Interface_Alias (Prim)) = Iface then Prim_Alias := Interface_Alias (Prim); - - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - + E := Ultimate_Alias (Prim); Pos := UI_To_Int (DT_Position (Prim_Alias)); if Present (Prim_Table (Pos)) then @@ -3908,7 +3878,7 @@ package body Exp_Disp is pragma Assert (Count = Nb_Prim); end; - OSD := Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + OSD := Make_Temporary (Loc, 'I'); Append_To (Result, Make_Object_Declaration (Loc, @@ -3921,21 +3891,23 @@ package body Exp_Disp is Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Integer_Literal (Loc, Nb_Prim)))), - Expression => Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), - Expression => - Make_Integer_Literal (Loc, Nb_Prim)), - Make_Component_Association (Loc, - Choices => New_List ( - New_Occurrence_Of - (RTE_Record_Component (RE_OSD_Table), Loc)), - Expression => Make_Aggregate (Loc, - Component_Associations => OSD_Aggr_List)))))); + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Num_Prims), Loc)), + Expression => + Make_Integer_Literal (Loc, Nb_Prim)), + + Make_Component_Association (Loc, + Choices => New_List ( + New_Occurrence_Of + (RTE_Record_Component (RE_OSD_Table), Loc)), + Expression => Make_Aggregate (Loc, + Component_Associations => OSD_Aggr_List)))))); Append_To (Result, Make_Attribute_Definition_Clause (Loc, @@ -3984,10 +3956,14 @@ package body Exp_Disp is while Present (Prim_Elmt) loop Prim := Node (Prim_Elmt); + -- Do not reference predefined primitives because they + -- are located in a separate dispatch table; skip also + -- abstract and eliminated primitives. + if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (Alias (Prim)) - and then not Is_Imported (Alias (Prim)) + and then not Is_Eliminated (Alias (Prim)) and then Find_Dispatching_Type (Interface_Alias (Prim)) = Iface @@ -4400,17 +4376,6 @@ package body Exp_Disp is New_Reference_To (RTE (RE_No_Dispatch_Table_Wrapper), Loc))); - -- Generate a SCIL node for the previous object declaration - -- because it has a null dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4443,9 +4408,8 @@ package body Exp_Disp is if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; -- Generate: @@ -4477,17 +4441,6 @@ package body Exp_Disp is Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => DT_Constr_List)))); - -- Generate the SCIL node for the previous object declaration - -- because it contains a dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -4520,9 +4473,8 @@ package body Exp_Disp is if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; Append_To (Result, @@ -4907,9 +4859,14 @@ package body Exp_Disp is -- Size_Func if RTE_Record_Component_Available (RE_Size_Func) then - if not Building_Static_DT (Typ) - or else Is_Interface (Typ) - then + + -- Initialize this field to Null_Address if we are not building + -- static dispatch tables static or if the size function is not + -- available. In the former case we cannot initialize this field + -- until the function is frozen and registered in the dispatch + -- table (see Register_Primitive). + + if not Building_Static_DT (Typ) or else not Has_DT (Typ) then Append_To (TSD_Aggr_List, Unchecked_Convert_To (RTE (RE_Size_Ptr), New_Reference_To (RTE (RE_Null_Address), Loc))); @@ -4925,9 +4882,7 @@ package body Exp_Disp is Prim := Node (Prim_Elmt); if Chars (Prim) = Name_uSize then - while Present (Alias (Prim)) loop - Prim := Alias (Prim); - end loop; + Prim := Ultimate_Alias (Prim); if Is_Abstract_Subprogram (Prim) then Append_To (TSD_Aggr_List, @@ -5292,17 +5247,6 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); - -- Generate the SCIL node for the previous object declaration - -- because it has a null dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -5384,14 +5328,11 @@ package body Exp_Disp is if Is_Predefined_Dispatching_Operation (Prim) and then not Is_Abstract_Subprogram (Prim) + and then not Is_Eliminated (Prim) and then not Present (Prim_Table (UI_To_Int (DT_Position (Prim)))) then - E := Prim; - while Present (Alias (E)) loop - E := Alias (E); - end loop; - + E := Ultimate_Alias (Prim); pragma Assert (not Is_Abstract_Subprogram (E)); Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; @@ -5420,10 +5361,8 @@ package body Exp_Disp is Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')), - Subtype_Indication => + Defining_Identifier => Make_Temporary (Loc, 'S'), + Subtype_Indication => New_Reference_To (RTE (RE_Address_Array), Loc)); Append_To (Result, Decl); @@ -5532,23 +5471,22 @@ package body Exp_Disp is E := Ultimate_Alias (Prim); - if Is_Imported (Prim) - or else Present (Interface_Alias (Prim)) - or else Is_Predefined_Dispatching_Operation (Prim) - or else Is_Eliminated (E) - then - null; + -- Do not reference predefined primitives because they are + -- located in a separate dispatch table; skip entities with + -- attribute Interface_Alias because they are only required + -- to build secondary dispatch tables; skip also abstract + -- and eliminated primitives. - else - if not Is_Predefined_Dispatching_Operation (E) - and then not Is_Abstract_Subprogram (E) - and then not Present (Interface_Alias (E)) - then - pragma Assert - (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); + if not Is_Predefined_Dispatching_Operation (Prim) + and then not Is_Predefined_Dispatching_Operation (E) + and then not Present (Interface_Alias (Prim)) + and then not Is_Abstract_Subprogram (E) + and then not Is_Eliminated (E) + then + pragma Assert + (UI_To_Int (DT_Position (Prim)) <= Nb_Prim); - Prim_Table (UI_To_Int (DT_Position (Prim))) := E; - end if; + Prim_Table (UI_To_Int (DT_Position (Prim))) := E; end if; Next_Elmt (Prim_Elmt); @@ -5609,17 +5547,6 @@ package body Exp_Disp is Expression => Make_Aggregate (Loc, Expressions => DT_Aggr_List))); - -- Generate the SCIL node for the previous object declaration - -- because it contains a dispatch table. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; - Append_To (Result, Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (DT, Loc), @@ -5949,7 +5876,7 @@ package body Exp_Disp is -- Mark entities containing dispatch tables. Required by the backend to -- handle them properly. - if not Is_Interface (Typ) then + if Has_DT (Typ) then declare Elmt : Elmt_Id; @@ -5981,6 +5908,10 @@ package body Exp_Disp is end; end if; + -- Register the tagged type in the call graph nodes table + + Register_CG_Node (Typ); + return Result; end Make_DT; @@ -6088,6 +6019,9 @@ package body Exp_Disp is -- Look for primitive overriding an abstract interface subprogram if Present (Interface_Alias (Prim)) + and then not + Is_Ancestor + (Find_Dispatching_Type (Interface_Alias (Prim)), Typ) and then not Examined (UI_To_Int (DT_Position (Alias (Prim)))) then Prim_Pos := DT_Position (Alias (Prim)); @@ -6108,10 +6042,7 @@ package body Exp_Disp is -- Retrieve the root of the alias chain - Prim_Als := Prim; - while Present (Alias (Prim_Als)) loop - Prim_Als := Alias (Prim_Als); - end loop; + Prim_Als := Ultimate_Alias (Prim); -- In the case of an entry wrapper, set the entry index @@ -6317,9 +6248,8 @@ package body Exp_Disp is if Generate_SCIL then New_Node := Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); + Set_SCIL_Node (Last (Result), New_Node); end if; Append_To (Result, @@ -6356,17 +6286,6 @@ package body Exp_Disp is New_Occurrence_Of (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)), Attribute_Name => Name_Address)))); - - -- Generate the SCIL node for the previous object declaration - -- because it has a tag initialization. - - if Generate_SCIL then - New_Node := - Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); - Set_SCIL_Related_Node (New_Node, Last (Result)); - Set_SCIL_Entity (New_Node, Typ); - Insert_Before (Last (Result), New_Node); - end if; end if; Set_Is_True_Constant (DT_Ptr); @@ -6643,10 +6562,7 @@ package body Exp_Disp is begin -- Retrieve the original primitive operation - Prim_Op := Prim; - while Present (Alias (Prim_Op)) loop - Prim_Op := Alias (Prim_Op); - end loop; + Prim_Op := Ultimate_Alias (Prim); if Ekind (Typ) = E_Record_Type and then Present (Corresponding_Concurrent_Type (Typ)) @@ -6744,7 +6660,11 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - if not RTE_Available (RE_Tag) then + -- Do not register in the dispatch table eliminated primitives + + if not RTE_Available (RE_Tag) + or else Is_Eliminated (Ultimate_Alias (Prim)) + then return L; end if; @@ -6809,6 +6729,13 @@ package body Exp_Disp is pragma Assert (Is_Interface (Iface_Typ)); + -- No action needed for interfaces that are ancestors of Typ because + -- their primitives are located in the primary dispatch table. + + if Is_Ancestor (Iface_Typ, Tag_Typ) then + return L; + end if; + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if not Is_Ancestor (Iface_Typ, Tag_Typ) @@ -7162,12 +7089,8 @@ package body Exp_Disp is Set_DT_Position (Prim, Default_Prim_Op_Position (Prim)); elsif Is_Predefined_Dispatching_Alias (Prim) then - E := Alias (Prim); - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - Set_DT_Position (Prim, Default_Prim_Op_Position (E)); + Set_DT_Position (Prim, + Default_Prim_Op_Position (Ultimate_Alias (Prim))); -- Overriding primitives of ancestor abstract interfaces @@ -7209,7 +7132,7 @@ package body Exp_Disp is Next_Elmt (Prim_Elmt); end loop; - -- Third stage: Fix the position of all the new primitives + -- Third stage: Fix the position of all the new primitives. -- Entries associated with primitives covering interfaces -- are handled in a latter round. @@ -7329,11 +7252,11 @@ package body Exp_Disp is Adjusted := True; end if; - -- An abstract operation cannot be declared in the private part - -- for a visible abstract type, because it could never be over- - -- ridden. For explicit declarations this is checked at the - -- point of declaration, but for inherited operations it must - -- be done when building the dispatch table. + -- An abstract operation cannot be declared in the private part for a + -- visible abstract type, because it can't be overridden outside this + -- package hierarchy. For explicit declarations this is checked at + -- the point of declaration, but for inherited operations it must be + -- done when building the dispatch table. -- Ada 2005 (AI-251): Primitives associated with interfaces are -- excluded from this check because interfaces must be visible in @@ -7597,6 +7520,17 @@ package body Exp_Disp is Write_Str ("(predefined) "); end if; + -- Prefix the name of the primitive with its corresponding tagged + -- type to facilitate seeing inherited primitives. + + if Present (Alias (Prim)) then + Write_Name + (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); + else + Write_Name (Chars (Typ)); + end if; + + Write_Str ("."); Write_Name (Chars (Prim)); -- Indicate if this primitive has an aliased primitive diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 6a653654800..5817d7ac73e 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -975,10 +975,10 @@ package body Exp_Dist is Defining_Unit_Name (Specification (Current_Declaration))), Asynchronous => Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then - Is_Asynchronous (Defining_Unit_Name (Specification - (Current_Declaration)))); + N_Procedure_Specification + and then + Is_Asynchronous (Defining_Unit_Name (Specification + (Current_Declaration)))); Append_To (Decls, Subp_Stubs); Analyze (Subp_Stubs); @@ -1293,9 +1293,7 @@ package body Exp_Dist is end if; if not Is_RAS then - RPC_Receiver := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + RPC_Receiver := Make_Temporary (Loc, 'P'); Specific_Build_RPC_Receiver_Body (RPC_Receiver => RPC_Receiver, @@ -1348,13 +1346,7 @@ package body Exp_Dist is -- primitive may have been inherited, go back the alias chain -- until the real primitive has been found. - Current_Primitive_Alias := Current_Primitive; - while Present (Alias (Current_Primitive_Alias)) loop - pragma Assert - (Current_Primitive_Alias - /= Alias (Current_Primitive_Alias)); - Current_Primitive_Alias := Alias (Current_Primitive_Alias); - end loop; + Current_Primitive_Alias := Ultimate_Alias (Current_Primitive); -- Copy the spec from the original declaration for the purpose -- of declaring an overriding subprogram: we need to replace @@ -1529,9 +1521,7 @@ package body Exp_Dist is Param_Assoc : constant List_Id := New_List; Stmts : constant List_Id := New_List; - RAS_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P'); Is_Function : constant Boolean := Nkind (Type_Def) = N_Access_Function_Definition; @@ -1897,8 +1887,7 @@ package body Exp_Dist is end if; Existing := False; - Stub_Type := - Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); + Stub_Type := Make_Temporary (Loc, 'S'); Set_Ekind (Stub_Type, E_Record_Type); Set_Is_RACW_Stub_Type (Stub_Type); Stub_Type_Access := @@ -2058,8 +2047,8 @@ package body Exp_Dist is declare Constant_Object : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('P')); + Make_Temporary (Loc, 'P'); + begin Set_Defining_Identifier (Last (Decls), Constant_Object); @@ -2429,9 +2418,10 @@ package body Exp_Dist is -- Start of processing for Build_Subprogram_Calling_Stubs begin - Subp_Spec := Copy_Specification (Loc, - Spec => Specification (Vis_Decl), - New_Name => New_Name); + Subp_Spec := + Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); if Locator = Empty then RCI_Locator := RCI_Cache; @@ -3019,9 +3009,7 @@ package body Exp_Dist is Remote_Statements : List_Id; -- Various parts of the procedure - Pnam : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); Asynchronous_Flag : constant Entity_Id := Asynchronous_Flags_Table.Get (RACW_Type); pragma Assert (Present (Asynchronous_Flag)); @@ -3063,16 +3051,11 @@ package body Exp_Dist is -- Prepare local identifiers - Source_Partition := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Source_Receiver := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Source_Address := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Local_Stub := - Make_Defining_Identifier (Loc, New_Internal_Name ('L')); - Stubbed_Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Source_Partition := Make_Temporary (Loc, 'P'); + Source_Receiver := Make_Temporary (Loc, 'S'); + Source_Address := Make_Temporary (Loc, 'P'); + Local_Stub := Make_Temporary (Loc, 'L'); + Stubbed_Result := Make_Temporary (Loc, 'S'); -- Generate object declarations @@ -3274,8 +3257,7 @@ package body Exp_Dist is Remote_Statements : List_Id; Null_Statements : List_Id; - Pnam : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); begin Build_Stream_Procedure @@ -3455,25 +3437,16 @@ package body Exp_Dist is Proc_Decls : List_Id; Proc_Statements : List_Id; - Origin : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Additional local variables for the local case - Proxy_Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Additional local variables for the remote case - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); function Set_Field (Field_Name : Name_Id; @@ -3699,18 +3672,15 @@ package body Exp_Dist is Request_Parameter : Node_Id; Pkg_RPC_Receiver : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('H')); + Make_Temporary (Loc, 'H'); Pkg_RPC_Receiver_Statements : List_Id; Pkg_RPC_Receiver_Cases : constant List_Id := New_List; Pkg_RPC_Receiver_Body : Node_Id; -- A Pkg_RPC_Receiver is built to decode the request - Lookup_RAS_Info : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - -- A remote subprogram is created to allow peers to look up - -- RAS information using subprogram ids. + Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); + -- A remote subprogram is created to allow peers to look up RAS + -- information using subprogram ids. Subp_Id : Entity_Id; Subp_Index : Entity_Id; @@ -3720,11 +3690,8 @@ package body Exp_Dist is Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; Current_Stubs : Node_Id; - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('I')); - - Subp_Info_List : constant List_Id := New_List; + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); + Subp_Info_List : constant List_Id := New_List; Register_Pkg_Actuals : constant List_Id := New_List; @@ -4165,8 +4132,7 @@ package body Exp_Dist is -- well as the declaration of Result. For a function call, 'Input is -- always used to read the result even if it is constrained. - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Stream_Parameter := Make_Temporary (Loc, 'S'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4182,8 +4148,7 @@ package body Exp_Dist is New_List (Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Result_Parameter := Make_Temporary (Loc, 'R'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4198,8 +4163,7 @@ package body Exp_Dist is Constraints => New_List (Make_Integer_Literal (Loc, 0)))))); - Exception_Return_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4318,8 +4282,7 @@ package body Exp_Dist is -- type and push it in the stream after the regular -- parameters. - Extra_Parameter := Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + Extra_Parameter := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -4556,7 +4519,7 @@ package body Exp_Dist is (RPC_Receiver => RPC_Receiver, Request_Parameter => Request); - Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Subp_Id := Make_Temporary (Loc, 'P'); Subp_Index := Subp_Id; -- Subp_Id may not be a constant, because in the case of the RPC @@ -4600,9 +4563,10 @@ package body Exp_Dist is Controlling_Parameter : Entity_Id) return RPC_Target is Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); + begin - Target_Info.Partition := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Target_Info.Partition := Make_Temporary (Loc, 'P'); + if Present (Controlling_Parameter) then Append_To (Decls, Make_Object_Declaration (Loc, @@ -4707,10 +4671,9 @@ package body Exp_Dist is begin RPC_Receiver_Decl := Make_Subprogram_Declaration (Loc, - Build_RPC_Receiver_Specification ( - RPC_Receiver => Make_Defining_Identifier (Loc, - New_Internal_Name ('R')), - Request_Parameter => RPC_Receiver_Request)); + Build_RPC_Receiver_Specification + (RPC_Receiver => Make_Temporary (Loc, 'R'), + Request_Parameter => RPC_Receiver_Request)); end; end if; end Build_Stub_Type; @@ -4729,9 +4692,7 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (Vis_Decl); - Request_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); -- Formal parameter for receiving stubs: a descriptor for an incoming -- request. @@ -4784,8 +4745,7 @@ package body Exp_Dist is end if; if Dynamically_Asynchronous then - Dynamic_Async := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Dynamic_Async := Make_Temporary (Loc, 'S'); else Dynamic_Async := Empty; end if; @@ -4830,9 +4790,7 @@ package body Exp_Dist is Need_Extra_Constrained : Boolean; -- True when an Extra_Constrained actual is required - Object : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('P')); + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); Expr : Node_Id := Empty; @@ -5051,9 +5009,8 @@ package body Exp_Dist is declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); - Result : constant Node_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); + begin Inner_Decls := New_List ( Make_Object_Declaration (Loc, @@ -5139,8 +5096,7 @@ package body Exp_Dist is -- exception occurrence is copied into the output stream and -- no other output parameter is written. - Excep_Choice := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Excep_Choice := Make_Temporary (Loc, 'E'); Excep_Code := New_List ( Make_Attribute_Reference (Loc, @@ -5171,8 +5127,7 @@ package body Exp_Dist is Subp_Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Defining_Unit_Name => Make_Temporary (Loc, 'F'), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, @@ -5308,10 +5263,10 @@ package body Exp_Dist is begin return Make_Subprogram_Body (Loc, - Specification => Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Result_Definition => New_Occurrence_Of (Var_Type, Loc)), + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Make_Temporary (Loc, 'S'), + Result_Definition => New_Occurrence_Of (Var_Type, Loc)), Declarations => No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List ( @@ -5394,8 +5349,7 @@ package body Exp_Dist is -------------------- function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is - Occ : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); begin return Make_Block_Statement (Loc, @@ -5762,8 +5716,7 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, Name_R); -- Various parts of the procedure - Pnam : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); @@ -5882,10 +5835,8 @@ package body Exp_Dist is RACW_Parameter : constant Entity_Id := Make_Defining_Identifier (Loc, Name_R); - Reference : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Any : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); begin Func_Spec := @@ -6074,8 +6025,7 @@ package body Exp_Dist is Attr_Decl : Node_Id; Statements : constant List_Id := New_List; - Pnam : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); function Stream_Parameter return Node_Id; function Object return Node_Id; @@ -6233,16 +6183,10 @@ package body Exp_Dist is Make_Defining_Identifier (Loc, Name_A); -- For the call to Get_Local_Address + Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); + Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); -- Additional local variables for the remote case - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); - - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - function Set_Field (Field_Name : Name_Id; Value : Node_Id) return Node_Id; @@ -6554,12 +6498,8 @@ package body Exp_Dist is Func_Spec : Node_Id; - Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); - RAS_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); + RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); RACW_Parameter : constant Node_Id := Make_Selected_Component (Loc, Prefix => RAS_Parameter, @@ -6675,8 +6615,7 @@ package body Exp_Dist is Loc : constant Source_Ptr := Sloc (Pkg_Spec); Pkg_RPC_Receiver : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('H')); + Make_Temporary (Loc, 'H'); Pkg_RPC_Receiver_Object : Node_Id; Pkg_RPC_Receiver_Body : Node_Id; Pkg_RPC_Receiver_Decls : List_Id; @@ -6697,13 +6636,9 @@ package body Exp_Dist is -- from the request structure, or the local subprogram address (in -- case of a RAS). - Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); - Local_Address : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); -- Address of a local subprogram designated by a reference -- corresponding to a RAS. @@ -6714,9 +6649,7 @@ package body Exp_Dist is Current_Stubs : Node_Id; Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('I')); + Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); Subp_Info_List : constant List_Id := New_List; @@ -7073,8 +7006,7 @@ package body Exp_Dist is Pkg_RPC_Receiver_Object := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('R')), + Defining_Identifier => Make_Temporary (Loc, 'R'), Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); Append_To (Decls, Pkg_RPC_Receiver_Object); @@ -7163,8 +7095,7 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (Nod); - Request : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Request : constant Entity_Id := Make_Temporary (Loc, 'R'); -- The request object constructed by these stubs -- Could we use Name_R instead??? (see GLADE client stubs) @@ -7247,9 +7178,7 @@ package body Exp_Dist is Object_Definition => New_Occurrence_Of (RTE (RE_Request_Access), Loc))); - Result := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Result := Make_Temporary (Loc, 'R'); if Is_Function then Result_TC := @@ -7285,8 +7214,7 @@ package body Exp_Dist is Expression => Make_Integer_Literal (Loc, 0)))))); if not Is_Known_Asynchronous then - Exception_Return_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Exception_Return_Parameter := Make_Temporary (Loc, 'E'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -7300,8 +7228,7 @@ package body Exp_Dist is -- Initialize and fill in arguments list - Arguments := - Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Arguments := Make_Temporary (Loc, 'A'); Declare_Create_NVList (Loc, Arguments, Decls, Statements); Current_Parameter := First (Ordered_Parameters_List); @@ -7336,9 +7263,7 @@ package body Exp_Dist is Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); - Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Any : constant Entity_Id := Make_Temporary (Loc, 'A'); Actual_Parameter : Node_Id := New_Occurrence_Of ( @@ -7447,8 +7372,7 @@ package body Exp_Dist is declare Extra_Any_Parameter : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + Make_Temporary (Loc, 'P'); Parameter_Exp : constant Node_Id := Make_Attribute_Reference (Loc, @@ -7595,9 +7519,8 @@ package body Exp_Dist is Controlling_Parameter : Entity_Id) return RPC_Target is Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); - Target_Reference : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); + Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); + begin if Present (Controlling_Parameter) then Append_To (Decls, @@ -7666,8 +7589,7 @@ package body Exp_Dist is RPC_Receiver_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Make_Defining_Identifier (Loc, - New_Internal_Name ('R')), + Defining_Identifier => Make_Temporary (Loc, 'R'), Aliased_Present => True, Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); @@ -7747,9 +7669,7 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (Vis_Decl); - Request_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); -- Formal parameter for receiving stubs: a descriptor for an incoming -- request. @@ -7793,9 +7713,7 @@ package body Exp_Dist is Build_Ordered_Parameters_List (Specification (Vis_Decl)); - Arguments : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); -- Name of the named values list used to retrieve parameters Subp_Spec : Node_Id; @@ -7825,11 +7743,9 @@ package body Exp_Dist is declare Etyp : Entity_Id; Constrained : Boolean; - Any : Entity_Id := Empty; - Object : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); - Expr : Node_Id := Empty; + Any : Entity_Id := Empty; + Object : constant Entity_Id := Make_Temporary (Loc, 'P'); + Expr : Node_Id := Empty; Is_Controlling_Formal : constant Boolean := Is_RACW_Controlling_Formal @@ -7865,9 +7781,7 @@ package body Exp_Dist is Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); if not Is_First_Controlling_Formal then - Any := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Any := Make_Temporary (Loc, 'A'); Append_To (Outer_Decls, Make_Object_Declaration (Loc, @@ -7891,13 +7805,10 @@ package body Exp_Dist is if Is_First_Controlling_Formal then declare - Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); Is_Local : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Make_Temporary (Loc, 'L'); begin -- Special case: obtain the first controlling formal @@ -8067,8 +7978,7 @@ package body Exp_Dist is (Current_Parameter)); Extra_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Make_Temporary (Loc, 'A'); Formal_Entity : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -8139,9 +8049,7 @@ package body Exp_Dist is declare Etyp : constant Entity_Id := Etype (Result_Definition (Specification (Vis_Decl))); - Result : constant Node_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); + Result : constant Node_Id := Make_Temporary (Loc, 'R'); begin Inner_Decls := New_List ( @@ -8209,8 +8117,7 @@ package body Exp_Dist is Subp_Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Defining_Unit_Name => Make_Temporary (Loc, 'F'), Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, @@ -8396,9 +8303,7 @@ package body Exp_Dist is N : Node_Id; Target : Entity_Id) is - Strm : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); Expr : Node_Id; Read_Call_List : List_Id; @@ -8456,9 +8361,7 @@ package body Exp_Dist is else declare - Temp : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('R')); + Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); begin Read_Call_List := New_List; @@ -8659,9 +8562,7 @@ package body Exp_Dist is Decls : constant List_Id := New_List; Stms : constant List_Id := New_List; - Any_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); Use_Opaque_Representation : Boolean; @@ -8744,9 +8645,7 @@ package body Exp_Dist is -- The returned object - Res : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('R')); + Res : constant Entity_Id := Make_Temporary (Loc, 'R'); Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); @@ -8813,8 +8712,7 @@ package body Exp_Dist is Choice_List : List_Id; Struct_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Make_Temporary (Loc, 'S'); begin Append_To (Decls, @@ -9454,7 +9352,7 @@ package body Exp_Dist is -- that the expected type of its parameter is U_Type. if Ekind (Fnam) = E_Function - and then Present (First_Formal (Fnam)) + and then Present (First_Formal (Fnam)) then C_Type := Etype (First_Formal (Fnam)); else @@ -9641,12 +9539,10 @@ package body Exp_Dist is Choice_List : List_Id; Union_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('V')); + Make_Temporary (Loc, 'V'); Struct_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Make_Temporary (Loc, 'S'); function Make_Discriminant_Reference return Node_Id; @@ -9865,8 +9761,7 @@ package body Exp_Dist is declare Dummy_Any : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('A')); + Make_Temporary (Loc, 'A'); begin Append_To (Decls, @@ -10016,9 +9911,7 @@ package body Exp_Dist is if Use_Opaque_Representation then declare - Strm : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); -- Stream used to store data representation produced by -- stream attribute. @@ -11192,9 +11085,7 @@ package body Exp_Dist is Pkg_Name := String_From_Name_Buffer; Inst := Make_Package_Instantiation (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')), + Defining_Unit_Name => Make_Temporary (Loc, 'R'), Name => New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb index fa878c2bf78..28b93b5f8a5 100644 --- a/gcc/ada/exp_fixd.adb +++ b/gcc/ada/exp_fixd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -505,8 +505,8 @@ package body Exp_Fixd is -- Define quotient and remainder, and set their Etypes, so -- that they can be picked up by Build_xxx routines. - Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); Set_Etype (Qnn, QR_Typ); Set_Etype (Rnn, QR_Typ); @@ -518,8 +518,8 @@ package body Exp_Fixd is -- Create temporaries for numerator and denominator and set Etypes, -- so that New_Occurrence_Of picks them up for Build_xxx calls. - Nnn := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); - Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); Set_Etype (Nnn, QR_Typ); Set_Etype (Dnn, QR_Typ); @@ -882,8 +882,8 @@ package body Exp_Fixd is -- Define quotient and remainder, and set their Etypes, so -- that they can be picked up by Build_xxx routines. - Qnn := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Rnn := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Qnn := Make_Temporary (Loc, 'S'); + Rnn := Make_Temporary (Loc, 'R'); Set_Etype (Qnn, QR_Typ); Set_Etype (Rnn, QR_Typ); @@ -891,8 +891,8 @@ package body Exp_Fixd is -- Case that we can compute the numerator in 64 bits if QR_Siz <= 64 then - Nnn := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); - Dnn := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Nnn := Make_Temporary (Loc, 'N'); + Dnn := Make_Temporary (Loc, 'D'); -- Set Etypes, so that they can be picked up by New_Occurrence_Of diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index cf4a9c02a80..9c0be21634e 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,9 +43,15 @@ with Stringt; use Stringt; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; +with Urealp; use Urealp; package body Exp_Imgv is + function Has_Decimal_Small (E : Entity_Id) return Boolean; + -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an + -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. + -- Shouldn't this be in einfo.adb or sem_aux.adb??? + ------------------------------------ -- Build_Enumeration_Image_Tables -- ------------------------------------ @@ -260,13 +266,8 @@ package body Exp_Imgv is Ins_List : List_Id; -- List of actions to be inserted - Snn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - Pnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Snn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin -- Build declarations of Snn and Pnn to be inserted @@ -335,7 +336,7 @@ package body Exp_Imgv is Tent := RTE (RE_Long_Long_Unsigned); end if; - elsif Is_Decimal_Fixed_Point_Type (Rtyp) then + elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then Imid := RE_Image_Decimal; Tent := Standard_Integer; @@ -358,8 +359,8 @@ package body Exp_Imgv is if Discard_Names (First_Subtype (Ptyp)) or else No (Lit_Strings (Root_Type (Ptyp))) then - -- When pragma Discard_Names applies to the first subtype, - -- then build (Pref'Pos)'Img. + -- When pragma Discard_Names applies to the first subtype, build + -- (Pref'Pos)'Img. Rewrite (N, Make_Attribute_Reference (Loc, @@ -380,8 +381,10 @@ package body Exp_Imgv is if Ttyp = Standard_Integer_8 then Imid := RE_Image_Enumeration_8; - elsif Ttyp = Standard_Integer_16 then + + elsif Ttyp = Standard_Integer_16 then Imid := RE_Image_Enumeration_16; + else Imid := RE_Image_Enumeration_32; end if; @@ -454,18 +457,23 @@ package body Exp_Imgv is Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Aft)); + if Has_Decimal_Small (Rtyp) then + Set_Conversion_OK (First (Arg_List)); + Set_Etype (First (Arg_List), Tent); + end if; + -- For decimal, append Scale and also set to do literal conversion elsif Is_Decimal_Fixed_Point_Type (Rtyp) then Append_To (Arg_List, Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Ptyp, Loc), + Prefix => New_Reference_To (Ptyp, Loc), Attribute_Name => Name_Scale)); Set_Conversion_OK (First (Arg_List)); Set_Etype (First (Arg_List), Tent); - -- For Wide_Character, append Ada 2005 indication + -- For Wide_Character, append Ada 2005 indication elsif Rtyp = Standard_Wide_Character then Append_To (Arg_List, @@ -771,14 +779,8 @@ package body Exp_Imgv is procedure Expand_Wide_Image_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); - - Rnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - Lnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin Insert_Actions (N, New_List ( @@ -869,13 +871,8 @@ package body Exp_Imgv is Loc : constant Source_Ptr := Sloc (N); Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); - Rnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - - Lnn : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin Insert_Actions (N, New_List ( @@ -1254,4 +1251,16 @@ package body Exp_Imgv is Analyze_And_Resolve (N, Typ); end Expand_Width_Attribute; + ----------------------- + -- Has_Decimal_Small -- + ----------------------- + + function Has_Decimal_Small (E : Entity_Id) return Boolean is + begin + return Is_Decimal_Fixed_Point_Type (E) + or else + (Is_Ordinary_Fixed_Point_Type (E) + and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); + end Has_Decimal_Small; + end Exp_Imgv; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index da6cf5a988c..0c4a67cb684 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -63,6 +63,10 @@ package body Exp_Intr is -- Local Subprograms -- ----------------------- + procedure Expand_Binary_Operator_Call (N : Node_Id); + -- Expand a call to an intrinsic arithmetic operator when the operand + -- types or sizes are not identical. + procedure Expand_Is_Negative (N : Node_Id); -- Expand a call to the intrinsic Is_Negative function @@ -108,6 +112,49 @@ package body Exp_Intr is -- Name_Source_Location - expand string of form file:line -- Name_Enclosing_Entity - expand string with name of enclosing entity + --------------------------------- + -- Expand_Binary_Operator_Call -- + --------------------------------- + + procedure Expand_Binary_Operator_Call (N : Node_Id) is + T1 : constant Entity_Id := Underlying_Type (Left_Opnd (N)); + T2 : constant Entity_Id := Underlying_Type (Right_Opnd (N)); + TR : constant Entity_Id := Etype (N); + T3 : Entity_Id; + Res : Node_Id; + + Siz : constant Uint := UI_Max (Esize (T1), Esize (T2)); + -- Maximum of operand sizes + + begin + -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64 + + if Siz > 32 then + T3 := RTE (RE_Unsigned_64); + else + T3 := RTE (RE_Unsigned_32); + end if; + + -- Copy operator node, and reset type and entity fields, for + -- subsequent reanalysis. + + Res := New_Copy (N); + Set_Etype (Res, Empty); + Set_Entity (Res, Empty); + + -- Convert operands to large enough intermediate type + + Set_Left_Opnd (Res, + Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N)))); + Set_Right_Opnd (Res, + Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N)))); + + -- Analyze and resolve result formed by conversion to target type + + Rewrite (N, Unchecked_Convert_To (TR, Res)); + Analyze_And_Resolve (N, TR); + end Expand_Binary_Operator_Call; + ----------------------------------------- -- Expand_Dispatching_Constructor_Call -- ----------------------------------------- @@ -171,11 +218,10 @@ package body Exp_Intr is Iface_Tag := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('V')), - Object_Definition => + Defining_Identifier => Make_Temporary (Loc, 'V'), + Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), - Expression => + Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc), Parameter_Associations => New_List ( @@ -325,7 +371,7 @@ package body Exp_Intr is -- be referencing it by normal visibility methods. if No (Choice_Parameter (P)) then - E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + E := Make_Temporary (Loc, 'E'); Set_Choice_Parameter (P, E); Set_Ekind (E, E_Variable); Set_Etype (E, RTE (RE_Exception_Occurrence)); @@ -362,11 +408,9 @@ package body Exp_Intr is Loc : constant Source_Ptr := Sloc (N); Ent : constant Entity_Id := Entity (Name (N)); Str : constant Node_Id := First_Actual (N); - Dum : Entity_Id; + Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); begin - Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); - Insert_Actions (N, New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Dum, @@ -490,6 +534,9 @@ package body Exp_Intr is elsif Present (Alias (E)) then Expand_Intrinsic_Call (N, Alias (E)); + elsif Nkind (N) in N_Binary_Op then + Expand_Binary_Operator_Call (N); + -- The only other case is where an external name was specified, -- since this is the only way that an otherwise unrecognized -- name could escape the checking in Sem_Prag. Nothing needs @@ -1025,13 +1072,11 @@ package body Exp_Intr is D_Type := Entity (D_Subtyp); else - D_Type := Make_Defining_Identifier (Loc, - New_Internal_Name ('A')); + D_Type := Make_Temporary (Loc, 'A'); Insert_Action (Deref, Make_Subtype_Declaration (Loc, Defining_Identifier => D_Type, Subtype_Indication => D_Subtyp)); - end if; -- Force freezing at the point of the dereference. For the diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index c1d25c2d68f..bd8a69771a4 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -455,6 +455,15 @@ package body Exp_Pakd is -- expression whose type is the implementation type used to represent -- the packed array. Aexp is analyzed and resolved on entry and on exit. + procedure Get_Base_And_Bit_Offset + (N : Node_Id; + Base : out Node_Id; + Offset : out Node_Id); + -- Given a node N for a name which involves a packed array reference, + -- return the base object of the reference and build an expression of + -- type Standard.Integer representing the zero-based offset in bits + -- from Base'Address to the first bit of the reference. + function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean; -- There are two versions of the Set routines, the ones used when the -- object is known to be sufficiently well aligned given the number of @@ -1347,10 +1356,9 @@ package body Exp_Pakd is begin Decl := Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('T')), - Object_Definition => New_Occurrence_Of (Ctyp, Loc), - Expression => New_Copy_Tree (Rhs)); + Defining_Identifier => Make_Temporary (Loc, 'T', Rhs), + Object_Definition => New_Occurrence_Of (Ctyp, Loc), + Expression => New_Copy_Tree (Rhs)); Insert_Actions (N, New_List (Decl)); Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc); @@ -1373,6 +1381,19 @@ package body Exp_Pakd is Analyze_And_Resolve (Rhs, Ctyp); end if; + -- For the AAMP target, indexing of certain packed array is passed + -- through to the back end without expansion, because the expansion + -- results in very inefficient code on that target. This allows the + -- GNAAMP back end to generate specialized macros that support more + -- efficient indexing of packed arrays with components having sizes + -- that are small powers of two. + + if AAMP_On_Target + and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) + then + return; + end if; + -- 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. @@ -1664,18 +1685,11 @@ package body Exp_Pakd is procedure Expand_Packed_Address_Reference (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Ploc : Source_Ptr; - Pref : Node_Id; - Expr : Node_Id; - Term : Node_Id; - Atyp : Entity_Id; - Subscr : Node_Id; + Base : Node_Id; + Offset : Node_Id; begin - Pref := Prefix (N); - Expr := Empty; - - -- We build up an expression serially that has the form + -- We build an expression that has the form -- outer_object'Address -- + (linear-subscript * component_size for each array reference @@ -1683,49 +1697,7 @@ package body Exp_Pakd is -- + ... -- + ...) / Storage_Unit; - -- Some additional conversions are required to deal with the addition - -- operation, which is not normally visible to generated code. - - loop - Ploc := Sloc (Pref); - - if Nkind (Pref) = N_Indexed_Component then - Convert_To_Actual_Subtype (Prefix (Pref)); - Atyp := Etype (Prefix (Pref)); - Compute_Linear_Subscript (Atyp, Pref, Subscr); - - Term := - Make_Op_Multiply (Ploc, - Left_Opnd => Subscr, - Right_Opnd => - Make_Attribute_Reference (Ploc, - Prefix => New_Occurrence_Of (Atyp, Ploc), - Attribute_Name => Name_Component_Size)); - - elsif Nkind (Pref) = N_Selected_Component then - Term := - Make_Attribute_Reference (Ploc, - Prefix => Selector_Name (Pref), - Attribute_Name => Name_Bit_Position); - - else - exit; - end if; - - Term := Convert_To (RTE (RE_Integer_Address), Term); - - if No (Expr) then - Expr := Term; - - else - Expr := - Make_Op_Add (Ploc, - Left_Opnd => Expr, - Right_Opnd => Term); - end if; - - Pref := Prefix (Pref); - end loop; + Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); Rewrite (N, Unchecked_Convert_To (RTE (RE_Address), @@ -1733,18 +1705,47 @@ package body Exp_Pakd is Left_Opnd => Unchecked_Convert_To (RTE (RE_Integer_Address), Make_Attribute_Reference (Loc, - Prefix => Pref, + Prefix => Base, Attribute_Name => Name_Address)), Right_Opnd => - Make_Op_Divide (Loc, - Left_Opnd => Expr, - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit))))); + Unchecked_Convert_To (RTE (RE_Integer_Address), + Make_Op_Divide (Loc, + Left_Opnd => Offset, + Right_Opnd => + Make_Integer_Literal (Loc, System_Storage_Unit)))))); Analyze_And_Resolve (N, RTE (RE_Address)); end Expand_Packed_Address_Reference; + --------------------------------- + -- Expand_Packed_Bit_Reference -- + --------------------------------- + + procedure Expand_Packed_Bit_Reference (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Base : Node_Id; + Offset : Node_Id; + + begin + -- We build an expression that has the form + + -- (linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + -- + ...) mod Storage_Unit; + + Get_Base_And_Bit_Offset (Prefix (N), Base, Offset); + + Rewrite (N, + Unchecked_Convert_To (Universal_Integer, + Make_Op_Mod (Loc, + Left_Opnd => Offset, + Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); + + Analyze_And_Resolve (N, Universal_Integer); + end Expand_Packed_Bit_Reference; + ------------------------------------ -- Expand_Packed_Boolean_Operator -- ------------------------------------ @@ -1841,11 +1842,8 @@ package body Exp_Pakd is else declare - Result_Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); - - E_Id : RE_Id; + Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); + E_Id : RE_Id; begin if Nkind (N) = N_Op_And then @@ -1948,6 +1946,19 @@ package body Exp_Pakd is Ctyp := Component_Type (Atyp); Csiz := UI_To_Int (Component_Size (Atyp)); + -- For the AAMP target, indexing of certain packed array is passed + -- through to the back end without expansion, because the expansion + -- results in very inefficient code on that target. This allows the + -- GNAAMP back end to generate specialized macros that support more + -- efficient indexing of packed arrays with components having sizes + -- that are small powers of two. + + if AAMP_On_Target + and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4) + then + return; + end if; + -- 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. @@ -2192,9 +2203,7 @@ package body Exp_Pakd is else declare - Result_Ent : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Insert_Actions (N, New_List ( @@ -2235,6 +2244,70 @@ package body Exp_Pakd is end Expand_Packed_Not; + ----------------------------- + -- Get_Base_And_Bit_Offset -- + ----------------------------- + + procedure Get_Base_And_Bit_Offset + (N : Node_Id; + Base : out Node_Id; + Offset : out Node_Id) + is + Loc : Source_Ptr; + Term : Node_Id; + Atyp : Entity_Id; + Subscr : Node_Id; + + begin + Base := N; + Offset := Empty; + + -- We build up an expression serially that has the form + + -- linear-subscript * component_size for each array reference + -- + field'Bit_Position for each record field + -- + ... + + loop + Loc := Sloc (Base); + + if Nkind (Base) = N_Indexed_Component then + Convert_To_Actual_Subtype (Prefix (Base)); + Atyp := Etype (Prefix (Base)); + Compute_Linear_Subscript (Atyp, Base, Subscr); + + Term := + Make_Op_Multiply (Loc, + Left_Opnd => Subscr, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Atyp, Loc), + Attribute_Name => Name_Component_Size)); + + elsif Nkind (Base) = N_Selected_Component then + Term := + Make_Attribute_Reference (Loc, + Prefix => Selector_Name (Base), + Attribute_Name => Name_Bit_Position); + + else + return; + end if; + + if No (Offset) then + Offset := Term; + + else + Offset := + Make_Op_Add (Loc, + Left_Opnd => Offset, + Right_Opnd => Term); + end if; + + Base := Prefix (Base); + end loop; + end Get_Base_And_Bit_Offset; + ------------------------------------- -- Involves_Packed_Array_Reference -- ------------------------------------- diff --git a/gcc/ada/exp_pakd.ads b/gcc/ada/exp_pakd.ads index 0c2e815e2ff..bd21a30effe 100644 --- a/gcc/ada/exp_pakd.ads +++ b/gcc/ada/exp_pakd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -272,4 +272,9 @@ package Exp_Pakd is -- the prefix involves a packed array reference. This routine expands the -- necessary code for performing the address reference in this case. + procedure Expand_Packed_Bit_Reference (N : Node_Id); + -- The node N is an attribute reference for the 'Bit reference, where the + -- prefix involves a packed array reference. This routine expands the + -- necessary code for performing the bit reference in this case. + end Exp_Pakd; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 7ff2f77eedb..987cddc0bbd 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -536,17 +536,14 @@ package body Exp_Prag is begin if Present (Call) then declare - Excep_Internal : constant Node_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('V')); - - Export_Pragma : Node_Id; - Excep_Alias : Node_Id; - Excep_Object : Node_Id; - Excep_Image : String_Id; - Exdata : List_Id; - Lang_Char : Node_Id; - Code : Node_Id; + Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); + Export_Pragma : Node_Id; + Excep_Alias : Node_Id; + Excep_Object : Node_Id; + Excep_Image : String_Id; + Exdata : List_Id; + Lang_Char : Node_Id; + Code : Node_Id; begin if Present (Interface_Name (Id)) then diff --git a/gcc/ada/exp_sel.adb b/gcc/ada/exp_sel.adb index 25d1a32b4c9..8250516a04f 100644 --- a/gcc/ada/exp_sel.adb +++ b/gcc/ada/exp_sel.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -83,19 +83,13 @@ package body Exp_Sel is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - B : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('B')); - + B : constant Entity_Id := Make_Temporary (Loc, 'B'); begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - B, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => - New_Reference_To (Standard_False, Loc))); - + Defining_Identifier => B, + Object_Definition => New_Reference_To (Standard_Boolean, Loc), + Expression => New_Reference_To (Standard_False, Loc))); return B; end Build_B; @@ -107,17 +101,12 @@ package body Exp_Sel is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - C : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')); - + C : constant Entity_Id := Make_Temporary (Loc, 'C'); begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - C, - Object_Definition => - New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); - + Defining_Identifier => C, + Object_Definition => New_Reference_To (RTE (RE_Prim_Op_Kind), Loc))); return C; end Build_C; @@ -155,9 +144,7 @@ package body Exp_Sel is Decls : List_Id; Obj : Entity_Id) return Entity_Id is - K : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('K')); - + K : constant Entity_Id := Make_Temporary (Loc, 'K'); begin Append_To (Decls, Make_Object_Declaration (Loc, @@ -169,7 +156,6 @@ package body Exp_Sel is Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Tag), Obj))))); - return K; end Build_K; @@ -181,16 +167,12 @@ package body Exp_Sel is (Loc : Source_Ptr; Decls : List_Id) return Entity_Id is - S : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - + S : constant Entity_Id := Make_Temporary (Loc, 'S'); begin Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => S, - Object_Definition => - New_Reference_To (Standard_Integer, Loc))); - + Object_Definition => New_Reference_To (Standard_Integer, Loc))); return S; end Build_S; diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index 6cbca26e0a8..f2cbfd083c9 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, 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- -- @@ -270,10 +270,7 @@ package body Exp_Smem is return False; else - if Ekind (Formal) = E_Out_Parameter - or else - Ekind (Formal) = E_In_Out_Parameter - then + if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then Insert_Node := Call; return True; else diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 42c34a8487e..ddb1064c475 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -1396,7 +1396,7 @@ package body Exp_Strm is -- If the enclosing record is an unchecked_union, we use the -- default expressions for the discriminant (it must exist) -- because we cannot generate a reference to it, given that - -- it is not stored.. + -- it is not stored. if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then D_Ref := diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1fc19daaefe..b9e5d389fce 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,6 @@ with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; -with Sem_SCIL; use Sem_SCIL; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -306,11 +305,9 @@ package body Exp_Util is else if No (Actions (Fnode)) then Set_Actions (Fnode, L); - else Append_List (L, Actions (Fnode)); end if; - end if; end Append_Freeze_Actions; @@ -398,7 +395,7 @@ package body Exp_Util is Pos : Entity_Id; -- Running index for substring assignments - Pref : Entity_Id; + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Name of enclosing variable, prefix of resulting name Res : Entity_Id; @@ -417,8 +414,6 @@ package body Exp_Util is Stats : constant List_Id := New_List; begin - Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - -- For a dynamic task, the name comes from the target variable. -- For a static one it is a formal of the enclosing init proc. @@ -444,7 +439,7 @@ package body Exp_Util is Val := First (Expressions (Id_Ref)); for J in 1 .. Dims loop - T := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + T := Make_Temporary (Loc, 'T'); Temps (J) := T; Append_To (Decls, @@ -454,10 +449,8 @@ package body Exp_Util is Expression => Make_Attribute_Reference (Loc, Attribute_Name => Name_Image, - Prefix => - New_Occurrence_Of (Etype (Indx), Loc), - Expressions => New_List ( - New_Copy_Tree (Val))))); + Prefix => New_Occurrence_Of (Etype (Indx), Loc), + Expressions => New_List (New_Copy_Tree (Val))))); Next_Index (Indx); Next (Val); @@ -613,7 +606,7 @@ package body Exp_Util is if Restriction_Active (No_Implicit_Heap_Allocations) or else Global_Discard_Names then - T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + T_Id := Make_Temporary (Loc, 'J'); Name_Len := 0; return @@ -697,9 +690,8 @@ package body Exp_Util is Expression => New_Occurrence_Of (Res, Loc))); Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - Result_Definition => New_Occurrence_Of (Standard_String, Loc)); + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + Result_Definition => New_Occurrence_Of (Standard_String, Loc)); -- Calls to 'Image use the secondary stack, which must be cleaned -- up after the task name is built. @@ -726,15 +718,15 @@ package body Exp_Util is Stats : List_Id) is begin - Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Len := Make_Temporary (Loc, 'L', Sum); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Len, - Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), - Expression => Sum)); + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => Sum)); - Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Res := Make_Temporary (Loc, 'R'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -750,12 +742,12 @@ package body Exp_Util is Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => New_Occurrence_Of (Len, Loc))))))); - Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Pos := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Pos, - Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); -- Pos := Prefix'Length; @@ -765,29 +757,29 @@ package body Exp_Util is Expression => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, - Prefix => New_Occurrence_Of (Prefix, Loc), - Expressions => - New_List (Make_Integer_Literal (Loc, 1))))); + Prefix => New_Occurrence_Of (Prefix, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1))))); -- Res (1 .. Pos) := Prefix; Append_To (Stats, - Make_Assignment_Statement (Loc, - Name => Make_Slice (Loc, - Prefix => New_Occurrence_Of (Res, Loc), + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), Discrete_Range => Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), + Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => New_Occurrence_Of (Pos, Loc))), - Expression => New_Occurrence_Of (Prefix, Loc))); + Expression => New_Occurrence_Of (Prefix, Loc))); Append_To (Stats, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Pos, Loc), + Name => New_Occurrence_Of (Pos, Loc), Expression => Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Pos, Loc), + Left_Opnd => New_Occurrence_Of (Pos, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1)))); end Build_Task_Image_Prefix; @@ -809,7 +801,7 @@ package body Exp_Util is Res : Entity_Id; -- String to hold result - Pref : Entity_Id; + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Name of enclosing variable, prefix of resulting name Sum : Node_Id; @@ -822,8 +814,6 @@ package body Exp_Util is Stats : constant List_Id := New_List; begin - Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - -- For a dynamic task, the name comes from the target variable. -- For a static one it is a formal of the enclosing init proc. @@ -845,15 +835,15 @@ package body Exp_Util is Name => Make_Identifier (Loc, Name_uTask_Name))); end if; - Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Sel := Make_Temporary (Loc, 'S'); Get_Name_String (Chars (Selector_Name (Id_Ref))); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Sel, - Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => Make_String_Literal (Loc, Strval => String_From_Name_Buffer))); @@ -1300,9 +1290,7 @@ package body Exp_Util is end if; else - T := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + T := Make_Temporary (Loc, 'T'); Insert_Action (N, Make_Subtype_Declaration (Loc, @@ -1496,7 +1484,7 @@ package body Exp_Util is -- Handle access types if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); + Typ := Designated_Type (Typ); end if; -- Handle task and protected types implementing interfaces @@ -1603,7 +1591,7 @@ package body Exp_Util is -- Handle access types if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); + Typ := Designated_Type (Typ); end if; -- Handle class-wide types @@ -1679,7 +1667,7 @@ package body Exp_Util is exit when Chars (Op) = Name and then (Name /= Name_Op_Eq - or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op))); + or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); Next_Elmt (Prim); @@ -2016,6 +2004,17 @@ package body Exp_Util is -- unknown before the ELSE part or after the IF statement. elsif Nkind (CV) = N_Elsif_Part then + + -- if the Elsif_Part had condition_actions, the elsif has been + -- rewritten as a nested if, and the original elsif_part is + -- detached from the tree, so there is no way to obtain useful + -- information on the current value of the variable. + -- Can this be improved ??? + + if No (Parent (CV)) then + return; + end if; + Stm := Parent (CV); -- Before start of ELSIF part @@ -2116,9 +2115,7 @@ package body Exp_Util is begin -- Only consider record types - if Ekind (Typ) /= E_Record_Type - and then Ekind (Typ) /= E_Record_Subtype - then + if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then return False; end if; @@ -2129,9 +2126,9 @@ package body Exp_Util is if Ekind (D_Typ) = E_Anonymous_Access_Type and then - (Is_Controlled (Directly_Designated_Type (D_Typ)) + (Is_Controlled (Designated_Type (D_Typ)) or else - Is_Concurrent_Type (Directly_Designated_Type (D_Typ))) + Is_Concurrent_Type (Designated_Type (D_Typ))) then return True; end if; @@ -2428,6 +2425,28 @@ package body Exp_Util is end if; end; + -- Alternative of case expression, we place the action in + -- the Actions field of the case expression alternative, this + -- will be handled when the case expression is expanded. + + when N_Case_Expression_Alternative => + if Present (Actions (P)) then + Insert_List_After_And_Analyze + (Last (Actions (P)), Ins_Actions); + else + Set_Actions (P, Ins_Actions); + Analyze_List (Then_Actions (P)); + end if; + + return; + + -- Case of appearing within an Expressions_With_Actions node. We + -- prepend the actions to the list of actions already there. + + when N_Expression_With_Actions => + Prepend_List (Ins_Actions, Actions (P)); + return; + -- Case of appearing in the condition of a while expression or -- elsif. We insert the actions into the Condition_Actions field. -- They will be moved further out when the while loop or elsif @@ -2683,6 +2702,7 @@ package body Exp_Util is N_Access_To_Object_Definition | N_Aggregate | N_Allocator | + N_Case_Expression | N_Case_Statement_Alternative | N_Character_Literal | N_Compilation_Unit | @@ -2789,11 +2809,9 @@ package body Exp_Util is N_Real_Range_Specification | N_Record_Definition | N_Reference | - N_SCIL_Dispatch_Table_Object_Init | N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call | N_SCIL_Membership_Test | - N_SCIL_Tag_Init | N_Selected_Component | N_Signed_Integer_Type_Definition | N_Single_Protected_Declaration | @@ -3124,16 +3142,23 @@ package body Exp_Util is end if; end if; + -- The following code is historical, it used to be present but it + -- is too cautious, because the front-end does not know the proper + -- default alignments for the target. Also, if the alignment is + -- not known, the front end can't know in any case! If a copy is + -- needed, the back-end will take care of it. This whole section + -- including this comment can be removed later ??? + -- If the component reference is for a record that has a specified -- alignment, and we either know it is too small, or cannot tell, - -- then the component may be unaligned + -- then the component may be unaligned. - if Known_Alignment (Etype (P)) - and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment - and then M > Alignment (Etype (P)) - then - return True; - end if; + -- if Known_Alignment (Etype (P)) + -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment + -- and then M > Alignment (Etype (P)) + -- then + -- return True; + -- end if; -- Case of component clause present which may specify an -- unaligned position. @@ -3755,24 +3780,27 @@ package body Exp_Util is Sizexpr : Node_Id; begin - if not Has_Discriminants (Root_Typ) then + -- If the root type is already constrained, there are no discriminants + -- in the expression. + + if not Has_Discriminants (Root_Typ) + or else Is_Constrained (Root_Typ) + then Constr_Root := Root_Typ; else - Constr_Root := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Constr_Root := Make_Temporary (Loc, 'R'); -- subtype cstr__n is T (List of discr constraints taken from Exp) Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Constr_Root, - Subtype_Indication => - Make_Subtype_From_Expr (E, Root_Typ))); + Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ))); end if; -- Generate the range subtype declaration - Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); + Range_Type := Make_Temporary (Loc, 'G'); if not Is_Interface (Root_Typ) then @@ -3821,7 +3849,7 @@ package body Exp_Util is -- subtype str__nn is Storage_Array (rg__x); - Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Str_Type := Make_Temporary (Loc, 'S'); Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Str_Type, @@ -3838,7 +3866,7 @@ package body Exp_Util is -- E : Str_Type; -- end Equiv_T; - Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Equiv_Type := Make_Temporary (Loc, 'T'); Set_Ekind (Equiv_Type, E_Record_Type); Set_Parent_Subtype (Equiv_Type, Constr_Root); @@ -3863,9 +3891,7 @@ package body Exp_Util is Append_To (Comp_List, Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')), + Defining_Identifier => Make_Temporary (Loc, 'C'), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, @@ -3991,15 +4017,12 @@ package body Exp_Util is -- actual or an explicit subtype. Utyp := Underlying_Type (Base_Type (Unc_Typ)); - Full_Subtyp := Make_Defining_Identifier (Loc, - New_Internal_Name ('C')); + Full_Subtyp := Make_Temporary (Loc, 'C'); Full_Exp := - Unchecked_Convert_To - (Utyp, Duplicate_Subexpr_No_Checks (E)); + Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E)); Set_Parent (Full_Exp, Parent (E)); - Priv_Subtyp := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Priv_Subtyp := Make_Temporary (Loc, 'P'); Insert_Action (E, Make_Subtype_Declaration (Loc, @@ -4058,6 +4081,20 @@ package body Exp_Util is -- additional intermediate type to handle the assignment). if Expander_Active and then Tagged_Type_Expansion then + + -- If this is the class_wide type of a completion that is + -- a record subtype, set the type of the class_wide type + -- to be the full base type, for use in the expanded code + -- for the equivalent type. Should this be done earlier when + -- the completion is analyzed ??? + + if Is_Private_Type (Etype (Unc_Typ)) + and then + Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype + then + Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ)))); + end if; + EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); end if; @@ -4422,9 +4459,7 @@ package body Exp_Util is -- already rewritten a variable node with a constant as -- a result of an earlier Force_Evaluation call. - if Ekind (Entity (N)) = E_Constant - or else Ekind (Entity (N)) = E_In_Parameter - then + if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then return True; -- Functions are not side effect free @@ -4662,14 +4697,15 @@ package body Exp_Util is Scope_Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make - -- a copy. Likewise for a function call, an attribute reference or an - -- operator. And if we have a volatile reference and Name_Req is not - -- set (see comments above for Side_Effect_Free). + -- a copy. Likewise for a function call, an attribute reference, an + -- allocator, or an operator. And if we have a volatile reference and + -- Name_Req is not set (see comments above for Side_Effect_Free). if Is_Elementary_Type (Exp_Type) and then (Variable_Ref or else Nkind (Exp) = N_Function_Call or else Nkind (Exp) = N_Attribute_Reference + or else Nkind (Exp) = N_Allocator or else Nkind (Exp) in N_Op or else (not Name_Req and then Is_Volatile_Reference (Exp))) then @@ -4684,15 +4720,6 @@ package body Exp_Util is Constant_Present => True, Expression => Relocate_Node (Exp)); - -- Check if the previous node relocation requires readjustment of - -- some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Expression (E)); - end if; - Set_Assignment_OK (E); Insert_Action (Exp, E); @@ -4854,15 +4881,6 @@ package body Exp_Util is Object_Definition => New_Occurrence_Of (Exp_Type, Loc), Expression => Relocate_Node (Exp)); - -- Check if the previous node relocation requires readjustment - -- of some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Expression (Decl)); - end if; - Insert_Action (Exp, Decl); Set_Etype (Obj, Exp_Type); Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); @@ -4870,7 +4888,7 @@ package body Exp_Util is end; end if; - Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ref_Type := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -4922,15 +4940,6 @@ package body Exp_Util is Defining_Identifier => Def_Id, Object_Definition => New_Reference_To (Ref_Type, Loc), Expression => New_Exp)); - - -- Check if the previous node relocation requires readjustment - -- of some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Prefix (New_Exp)); - end if; end if; -- Preserve the Assignment_OK flag in all copies, since at least diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 674137df1da..cc2122dd6e6 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -163,6 +163,9 @@ package body Expander is when N_Block_Statement => Expand_N_Block_Statement (N); + when N_Case_Expression => + Expand_N_Case_Expression (N); + when N_Case_Statement => Expand_N_Case_Statement (N); @@ -470,7 +473,6 @@ package body Expander is Debug_A_Exit ("expanding ", N, " (done)"); end if; - end Expand; --------------------------- diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb index 8de27ec6b7e..171f7a18e7d 100644 --- a/gcc/ada/fmap.adb +++ b/gcc/ada/fmap.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,10 @@ with Output; use Output; with Table; with Types; use Types; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); with Unchecked_Conversion; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e29904f158f..584ec944058 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -36,6 +36,7 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Util; use Exp_Util; with Exp_Tss; use Exp_Tss; with Layout; use Layout; +with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -203,12 +204,64 @@ package body Freeze is New_S : Entity_Id; After : in out Node_Id) is - Body_Node : constant Node_Id := Build_Renamed_Body (Decl, New_S); + Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S); + Ent : constant Entity_Id := Defining_Entity (Decl); + Body_Node : Node_Id; + Renamed_Subp : Entity_Id; + begin - Insert_After (After, Body_Node); - Mark_Rewrite_Insertion (Body_Node); - Analyze (Body_Node); - After := Body_Node; + -- If the renamed subprogram is intrinsic, there is no need for a + -- wrapper body: we set the alias that will be called and expanded which + -- completes the declaration. This transformation is only legal if the + -- renamed entity has already been elaborated. + + -- Note that it is legal for a renaming_as_body to rename an intrinsic + -- subprogram, as long as the renaming occurs before the new entity + -- is frozen. See RM 8.5.4 (5). + + if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration + and then Is_Entity_Name (Name (Body_Decl)) + then + Renamed_Subp := Entity (Name (Body_Decl)); + else + Renamed_Subp := Empty; + end if; + + if Present (Renamed_Subp) + and then Is_Intrinsic_Subprogram (Renamed_Subp) + and then + (not In_Same_Source_Unit (Renamed_Subp, Ent) + or else Sloc (Renamed_Subp) < Sloc (Ent)) + + -- We can make the renaming entity intrisic if the renamed function + -- has an interface name, or if it is one of the shift/rotate + -- operations known to the compiler. + + and then (Present (Interface_Name (Renamed_Subp)) + or else Chars (Renamed_Subp) = Name_Rotate_Left + or else Chars (Renamed_Subp) = Name_Rotate_Right + or else Chars (Renamed_Subp) = Name_Shift_Left + or else Chars (Renamed_Subp) = Name_Shift_Right + or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic) + then + Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); + + if Present (Alias (Renamed_Subp)) then + Set_Alias (Ent, Alias (Renamed_Subp)); + else + Set_Alias (Ent, Renamed_Subp); + end if; + + Set_Is_Intrinsic_Subprogram (Ent); + Set_Has_Completion (Ent); + + else + Body_Node := Build_Renamed_Body (Decl, New_S); + Insert_After (After, Body_Node); + Mark_Rewrite_Insertion (Body_Node); + Analyze (Body_Node); + After := Body_Node; + end if; end Build_And_Analyze_Renamed_Body; ------------------------ @@ -220,12 +273,12 @@ package body Freeze is New_S : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (New_S); - -- We use for the source location of the renamed body, the location - -- of the spec entity. It might seem more natural to use the location - -- of the renaming declaration itself, but that would be wrong, since - -- then the body we create would look as though it was created far - -- too late, and this could cause problems with elaboration order - -- analysis, particularly in connection with instantiations. + -- We use for the source location of the renamed body, the location of + -- the spec entity. It might seem more natural to use the location of + -- the renaming declaration itself, but that would be wrong, since then + -- the body we create would look as though it was created far too late, + -- and this could cause problems with elaboration order analysis, + -- particularly in connection with instantiations. N : constant Node_Id := Unit_Declaration_Node (New_S); Nam : constant Node_Id := Name (N); @@ -301,18 +354,16 @@ package body Freeze is Call_Name := New_Copy (Name (N)); end if; - -- The original name may have been overloaded, but - -- is fully resolved now. + -- Original name may have been overloaded, but is fully resolved now Set_Is_Overloaded (Call_Name, False); end if; -- For simple renamings, subsequent calls can be expanded directly as - -- called to the renamed entity. The body must be generated in any case - -- for calls they may appear elsewhere. + -- calls to the renamed entity. The body must be generated in any case + -- for calls that may appear elsewhere. - if (Ekind (Old_S) = E_Function - or else Ekind (Old_S) = E_Procedure) + if Ekind_In (Old_S, E_Function, E_Procedure) and then Nkind (Decl) = N_Subprogram_Declaration then Set_Body_To_Inline (Decl, Old_S); @@ -331,7 +382,6 @@ package body Freeze is Form_Type : constant Entity_Id := Etype (First_Formal (Old_S)); begin - -- The controlling formal may be an access parameter, or the -- actual may be an access value, so adjust accordingly. @@ -380,10 +430,8 @@ package body Freeze is if Present (Formal) then O_Formal := First_Formal (Old_S); Param_Spec := First (Parameter_Specifications (Spec)); - while Present (Formal) loop if Is_Entry (Old_S) then - if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then @@ -446,7 +494,6 @@ package body Freeze is Make_Defining_Identifier (Loc, Chars => Chars (New_S))); Param_Spec := First (Parameter_Specifications (Spec)); - while Present (Param_Spec) loop Set_Defining_Identifier (Param_Spec, Make_Defining_Identifier (Loc, @@ -515,27 +562,20 @@ package body Freeze is if (No (Expression (Decl)) and then not Needs_Finalization (Typ) - and then - (not Has_Non_Null_Base_Init_Proc (Typ) - or else Is_Imported (E))) - - or else - (Present (Expression (Decl)) - and then Is_Scalar_Type (Typ)) - - or else - Is_Access_Type (Typ) - + and then (not Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Imported (E))) + or else (Present (Expression (Decl)) and then Is_Scalar_Type (Typ)) + or else Is_Access_Type (Typ) or else (Is_Bit_Packed_Array (Typ) - and then - Is_Modular_Integer_Type (Packed_Array_Type (Typ))) + and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))) then null; -- Otherwise, we require the address clause to be constant because -- the call to the initialization procedure (or the attach code) has -- to happen at the point of the declaration. + -- Actually the IP call has been moved to the freeze actions -- anyway, so maybe we can relax this restriction??? @@ -551,7 +591,36 @@ package body Freeze is end if; end if; - if not Error_Posted (Expr) + -- If Rep_Clauses are to be ignored, remove address clause from + -- list attached to entity, because it may be illegal for gigi, + -- for example by breaking order of elaboration.. + + if Ignore_Rep_Clauses then + declare + Rep : Node_Id; + + begin + Rep := First_Rep_Item (E); + + if Rep = Addr then + Set_First_Rep_Item (E, Next_Rep_Item (Addr)); + + else + while Present (Rep) + and then Next_Rep_Item (Rep) /= Addr + loop + Rep := Next_Rep_Item (Rep); + end loop; + end if; + + if Present (Rep) then + Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr)); + end if; + end; + + Rewrite (Addr, Make_Null_Statement (Sloc (E))); + + elsif not Error_Posted (Expr) and then not Needs_Finalization (Typ) then Warn_Overlay (Expr, Typ, Name (Addr)); @@ -789,7 +858,7 @@ package body Freeze is and then Present (Parent (T)) and then Nkind (Parent (T)) = N_Full_Type_Declaration and then Nkind (Type_Definition (Parent (T))) = - N_Record_Definition + N_Record_Definition and then not Null_Present (Type_Definition (Parent (T))) and then Present (Variant_Part (Component_List (Type_Definition (Parent (T))))) @@ -801,8 +870,7 @@ package body Freeze is if not Is_Constrained (T) and then - No (Discriminant_Default_Value - (First_Discriminant (T))) + No (Discriminant_Default_Value (First_Discriminant (T))) and then Unknown_Esize (T) then return False; @@ -1145,10 +1213,7 @@ package body Freeze is if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement) and then Comes_From_Source (Par) then - Temp := - Make_Defining_Identifier (Loc, - New_Internal_Name ('T')); - + Temp := Make_Temporary (Loc, 'T', E); New_N := Make_Object_Declaration (Loc, Defining_Identifier => Temp, @@ -1191,10 +1256,7 @@ package body Freeze is -- Freeze_All_Ent -- -------------------- - procedure Freeze_All_Ent - (From : Entity_Id; - After : in out Node_Id) - is + procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is E : Entity_Id; Flist : List_Id; Lastn : Node_Id; @@ -1277,7 +1339,6 @@ package body Freeze is begin Prim := First_Elmt (Prim_List); - while Present (Prim) loop Subp := Node (Prim); @@ -1312,11 +1373,11 @@ package body Freeze is Bod : constant Node_Id := Next (After); begin - if (Nkind (Bod) = N_Subprogram_Body - or else Nkind (Bod) = N_Entry_Body - or else Nkind (Bod) = N_Package_Body - or else Nkind (Bod) = N_Protected_Body - or else Nkind (Bod) = N_Task_Body + if (Nkind_In (Bod, N_Subprogram_Body, + N_Entry_Body, + N_Package_Body, + N_Protected_Body, + N_Task_Body) or else Nkind (Bod) in N_Body_Stub) and then List_Containing (After) = List_Containing (Parent (E)) @@ -1343,6 +1404,9 @@ package body Freeze is -- point at which such functions are constructed (after all types that -- might be used in such expressions have been frozen). + -- For subprograms that are renaming_as_body, we create the wrapper + -- bodies as needed. + -- We also add finalization chains to access types whose designated -- types are controlled. This is normally done when freezing the type, -- but this misses recursive type definitions where the later members @@ -1383,11 +1447,10 @@ package body Freeze is then declare Ent : Entity_Id; + begin Ent := First_Entity (E); - while Present (Ent) loop - if Is_Entry (Ent) and then not Default_Expressions_Processed (Ent) then @@ -1776,7 +1839,7 @@ package body Freeze is Prev := Empty; while Present (Comp) loop - -- First handle the (real) component case + -- First handle the component case if Ekind (Comp) = E_Component or else Ekind (Comp) = E_Discriminant @@ -1847,129 +1910,12 @@ package body Freeze is Component_Name (Component_Clause (Comp))); end if; end if; - - -- If component clause is present, then deal with the non- - -- default bit order case for Ada 95 mode. The required - -- processing for Ada 2005 mode is handled separately after - -- processing all components. - - -- We only do this processing for the base type, and in - -- fact that's important, since otherwise if there are - -- record subtypes, we could reverse the bits once for - -- each subtype, which would be incorrect. - - if Present (CC) - and then Reverse_Bit_Order (Rec) - and then Ekind (E) = E_Record_Type - and then Ada_Version <= Ada_95 - then - declare - CFB : constant Uint := Component_Bit_Offset (Comp); - CSZ : constant Uint := Esize (Comp); - CLC : constant Node_Id := Component_Clause (Comp); - Pos : constant Node_Id := Position (CLC); - FB : constant Node_Id := First_Bit (CLC); - - Storage_Unit_Offset : constant Uint := - CFB / System_Storage_Unit; - - Start_Bit : constant Uint := - CFB mod System_Storage_Unit; - - begin - -- Cases where field goes over storage unit boundary - - if Start_Bit + CSZ > System_Storage_Unit then - - -- Allow multi-byte field but generate warning - - if Start_Bit mod System_Storage_Unit = 0 - and then CSZ mod System_Storage_Unit = 0 - then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CLC); - - if Bytes_Big_Endian then - Error_Msg_N - ("bytes are not reversed " - & "(component is big-endian)?", CLC); - else - Error_Msg_N - ("bytes are not reversed " - & "(component is little-endian)?", CLC); - end if; - - -- Do not allow non-contiguous field - - else - Error_Msg_N - ("attempt to specify non-contiguous field " - & "not permitted", CLC); - Error_Msg_N - ("\caused by non-standard Bit_Order " - & "specified", CLC); - Error_Msg_N - ("\consider possibility of using " - & "Ada 2005 mode here", CLC); - end if; - - -- Case where field fits in one storage unit - - else - -- Give warning if suspicious component clause - - if Intval (FB) >= System_Storage_Unit - and then Warn_On_Reverse_Bit_Order - then - Error_Msg_N - ("?Bit_Order clause does not affect " & - "byte ordering", Pos); - Error_Msg_Uint_1 := - Intval (Pos) + Intval (FB) / - System_Storage_Unit; - Error_Msg_N - ("?position normalized to ^ before bit " & - "order interpreted", Pos); - end if; - - -- Here is where we fix up the Component_Bit_Offset - -- value to account for the reverse bit order. - -- Some examples of what needs to be done are: - - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new - - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 - - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 - - -- The general rule is that the first bit is - -- is obtained by subtracting the old ending bit - -- from storage_unit - 1. - - Set_Component_Bit_Offset - (Comp, - (Storage_Unit_Offset * System_Storage_Unit) + - (System_Storage_Unit - 1) - - (Start_Bit + CSZ - 1)); - - Set_Normalized_First_Bit - (Comp, - Component_Bit_Offset (Comp) mod - System_Storage_Unit); - end if; - end; - end if; end; end if; - -- Gather data for possible Implicit_Packing later + -- Gather data for possible Implicit_Packing later. Note that at + -- this stage we might be dealing with a real component, or with + -- an implicit subtype declaration. if not Is_Scalar_Type (Etype (Comp)) then All_Scalar_Components := False; @@ -1982,12 +1928,12 @@ package body Freeze is -- If the component is an Itype with Delayed_Freeze and is either -- a record or array subtype and its base type has not yet been - -- frozen, we must remove this from the entity list of this - -- record and put it on the entity list of the scope of its base - -- type. Note that we know that this is not the type of a - -- component since we cleared Has_Delayed_Freeze for it in the - -- previous loop. Thus this must be the Designated_Type of an - -- access type, which is the type of a component. + -- frozen, we must remove this from the entity list of this record + -- and put it on the entity list of the scope of its base type. + -- Note that we know that this is not the type of a component + -- since we cleared Has_Delayed_Freeze for it in the previous + -- loop. Thus this must be the Designated_Type of an access type, + -- which is the type of a component. if Is_Itype (Comp) and then Is_Type (Scope (Comp)) @@ -2118,25 +2064,35 @@ package body Freeze is Next_Entity (Comp); end loop; - -- Deal with pragma Bit_Order + -- Deal with pragma Bit_Order setting non-standard bit order if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then if not Placed_Component then ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); - Error_Msg_N - ("?Bit_Order specification has no effect", ADC); + Error_Msg_N ("?Bit_Order specification has no effect", ADC); Error_Msg_N ("\?since no component clauses were specified", ADC); - -- Here is where we do Ada 2005 processing for bit order (the Ada - -- 95 case was already taken care of above). + -- Here is where we do the processing for reversed bit order - elsif Ada_Version >= Ada_05 then + else Adjust_Record_For_Reverse_Bit_Order (Rec); end if; end if; + -- Complete error checking on record representation clause (e.g. + -- overlap of components). This is called after adjusting the + -- record for reverse bit order. + + declare + RRC : constant Node_Id := Get_Record_Representation_Clause (Rec); + begin + if Present (RRC) then + Check_Record_Representation_Clause (RRC); + end if; + end; + -- Set OK_To_Reorder_Components depending on debug flags if Rec = Base_Type (Rec) @@ -2172,7 +2128,7 @@ package body Freeze is -- Give warning if redundant constructs warnings on if Warn_On_Redundant_Constructs then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?pragma Pack has no effect, no unplaced components", Get_Rep_Pragma (Rec, Name_Pack)); end if; @@ -2341,9 +2297,9 @@ package body Freeze is declare Sz : constant Node_Id := Size_Clause (Rec); begin - Error_Msg_NE -- CODEFIX + Error_Msg_NE -- CODEFIX ("size given for& too small", Sz, Rec); - Error_Msg_N -- CODEFIX + Error_Msg_N -- CODEFIX ("\use explicit pragma Pack " & "or use pragma Implicit_Packing", Sz); end; @@ -2400,6 +2356,7 @@ package body Freeze is S : Entity_Id := Current_Scope; begin + while Present (S) loop if Is_Overloadable (S) then if Comes_From_Source (S) @@ -2461,8 +2418,8 @@ package body Freeze is -- Skip this if the entity is stubbed, since we don't need a name -- for any stubbed routine. For the case on intrinsics, if no -- external name is specified, then calls will be handled in - -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed; if - -- an external name is provided, then Expand_Intrinsic_Call leaves + -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an + -- external name is provided, then Expand_Intrinsic_Call leaves -- calls in place for expansion by GIGI. if (Is_Imported (E) or else Is_Exported (E)) @@ -2572,8 +2529,7 @@ package body Freeze is and then not Has_Size_Clause (F_Type) and then VM_Target = No_VM then - Error_Msg_N - ("& is an 8-bit Ada Boolean?", Formal); + Error_Msg_N ("& is an 8-bit Ada Boolean?", Formal); Error_Msg_N ("\use appropriate corresponding type in C " & "(e.g. char)?", Formal); @@ -2840,7 +2796,8 @@ package body Freeze is Object_Definition (Parent (E))); if Is_CPP_Class (Etype (E)) then - Error_Msg_NE ("\} may need a cpp_constructor", + Error_Msg_NE + ("\} may need a cpp_constructor", Object_Definition (Parent (E)), Etype (E)); end if; end if; @@ -3120,7 +3077,7 @@ package body Freeze is else Error_Msg_NE ("size given for& too small", SZ, E); - Error_Msg_N + Error_Msg_N -- CODEFIX ("\use explicit pragma Pack " & "or use pragma Implicit_Packing", SZ); end if; @@ -4244,8 +4201,8 @@ package body Freeze is -- exiting from the loop when it is appropriate to insert the freeze -- node before the current node P. - -- Also checks som special exceptions to the freezing rules. These cases - -- result in a direct return, bypassing the freeze action. + -- Also checks some special exceptions to the freezing rules. These + -- cases result in a direct return, bypassing the freeze action. P := N; loop @@ -4422,6 +4379,8 @@ package body Freeze is N_Entry_Call_Alternative | N_Triggering_Alternative | N_Abortable_Part | + N_And_Then | + N_Or_Else | N_Freeze_Entity => exit when Is_List_Member (P); @@ -4510,8 +4469,8 @@ package body Freeze is Scope_Stack.Table (Pos).Pending_Freeze_Actions := Freeze_Nodes; else - Append_List (Freeze_Nodes, Scope_Stack.Table - (Pos).Pending_Freeze_Actions); + Append_List (Freeze_Nodes, + Scope_Stack.Table (Pos).Pending_Freeze_Actions); end if; end if; end; @@ -5413,6 +5372,26 @@ package body Freeze is return True; end; + -- For the designated type of an access to subprogram, all types in + -- the profile must be fully defined. + + elsif Ekind (T) = E_Subprogram_Type then + declare + F : Entity_Id; + + begin + F := First_Formal (T); + while Present (F) loop + if not Is_Fully_Defined (Etype (F)) then + return False; + end if; + + Next_Formal (F); + end loop; + + return Is_Fully_Defined (Etype (T)); + end; + else return not Is_Private_Type (T) or else Present (Full_View (Base_Type (T))); @@ -5523,8 +5502,7 @@ package body Freeze is -- involve secondary stack expansion. else - Dnam := - Make_Defining_Identifier (Loc, New_Internal_Name ('D')); + Dnam := Make_Temporary (Loc, 'D'); Dbody := Make_Subprogram_Body (Loc, diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 89746b88035..fb5eb4319f1 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -60,6 +60,7 @@ with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.L; use Sinput.L; +with SCIL_LL; use SCIL_LL; with Targparm; use Targparm; with Tbuild; use Tbuild; with Types; use Types; @@ -89,6 +90,10 @@ begin Sem_Warn.Initialize; Prep.Initialize; + if Generate_SCIL then + SCIL_LL.Initialize; + end if; + -- Create package Standard CStand.Create_Standard; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index 8752ddcff5f..cea2e7b12e8 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2009, AdaCore -- +-- Copyright (C) 1999-2010, 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- -- @@ -106,12 +106,12 @@ -- end loop; -- end; --- The example above have shown how to parse the command line when the --- arguments are read directly from Ada.Command_Line. However, these arguments --- can also be read from a list of strings. This can be useful in several --- contexts, either because your system does not support Ada.Command_Line, or --- because you are manipulating other tools and creating their command line by --- hand, or for any other reason. +-- The examples above show how to parse the command line when the arguments +-- are read directly from Ada.Command_Line. However, these arguments can also +-- be read from a list of strings. This can be useful in several contexts, +-- either because your system does not support Ada.Command_Line, or because +-- you are manipulating other tools and creating their command lines by hand, +-- or for any other reason. -- To create the list of strings, it is recommended to use -- GNAT.OS_Lib.Argument_String_To_List. @@ -140,10 +140,10 @@ -- adding or removing arguments from them. The resulting command line is kept -- as short as possible by coalescing arguments whenever possible. --- Complex command lines can thus be constructed, for example from an GUI +-- Complex command lines can thus be constructed, for example from a GUI -- (although this package does not by itself depend upon any specific GUI --- toolkit). For instance, if you are configuring the command line to use --- when spawning a tool with the following characteristics: +-- toolkit). For instance, if you are configuring the command line to use when +-- spawning a tool with the following characteristics: -- * Specifying -gnatwa is the same as specifying -gnatwu -gnatwv, but -- shorter and more readable @@ -298,7 +298,7 @@ package GNAT.Command_Line is -- as a switch (returned by getopt), otherwise it will be considered -- as a normal argument (returned by Get_Argument). -- - -- If SECTION_DELIMITERS is set, then every following subprogram + -- If Section_Delimiters is set, then every following subprogram -- (Getopt and Get_Argument) will only operate within a section, which -- is delimited by any of these delimiters or the end of the command line. -- @@ -306,9 +306,9 @@ package GNAT.Command_Line is -- Initialize_Option_Scan (Section_Delimiters => "largs bargs cargs"); -- -- Arguments on command line : my_application -c -bargs -d -e -largs -f - -- This line is made of three section, the first one is the default one + -- This line contains three sections, the first one is the default one -- and includes only the '-c' switch, the second one is between -bargs - -- and -largs and includes '-d -e' and the last one includes '-f' + -- and -largs and includes '-d -e' and the last one includes '-f'. procedure Free (Parser : in out Opt_Parser); -- Free the memory used by the parser. Calling this is not mandatory for @@ -317,16 +317,18 @@ package GNAT.Command_Line is procedure Goto_Section (Name : String := ""; Parser : Opt_Parser := Command_Line_Parser); - -- Change the current section. The next Getopt of Get_Argument will start + -- Change the current section. The next Getopt or Get_Argument will start -- looking at the beginning of the section. An empty name ("") refers to -- the first section between the program name and the first section - -- delimiter. If the section does not exist, then Invalid_Section is - -- raised. + -- delimiter. If the section does not exist in Section_Delimiters, then + -- Invalid_Section is raised. If the section does not appear on the command + -- line, then it is treated as an empty section. function Full_Switch (Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the full name of the last switch found (Getopt only returns - -- the first character) + -- Returns the full name of the last switch found (Getopt only returns the + -- first character). Does not include the Switch_Char ('-' by default), + -- unless the "*" option of Getopt is used (see below). function Getopt (Switches : String; @@ -336,13 +338,13 @@ package GNAT.Command_Line is -- switch character followed by a character within Switches, casing being -- significant). The result returned is the first character of the switch -- that is located. If there are no more switches in the current section, - -- returns ASCII.NUL. If Concatenate is True (by default), the switches - -- does not need to be separated by spaces (they can be concatenated if - -- they do not require an argument, e.g. -ab is the same as two separate - -- arguments -a -b). + -- returns ASCII.NUL. If Concatenate is True (the default), the switches do + -- not need to be separated by spaces (they can be concatenated if they do + -- not require an argument, e.g. -ab is the same as two separate arguments + -- -a -b). -- - -- Switches is a string of all the possible switches, separated by a - -- space. A switch can be followed by one of the following characters: + -- Switches is a string of all the possible switches, separated by + -- spaces. A switch can be followed by one of the following characters: -- -- ':' The switch requires a parameter. There can optionally be a space -- on the command line between the switch and its parameter. @@ -389,14 +391,14 @@ package GNAT.Command_Line is -- Example -- Getopt ("* a b") -- If the command line is '-a -c toto.o -b', Getopt will return - -- successively 'a', '*', '*' and 'b'. When '*' is returned, - -- Full_Switch returns the corresponding item on the command line. + -- successively 'a', '*', '*' and 'b', with Full_Switch returning + -- "a", "-c", "toto.o", and "b". -- -- When Getopt encounters an invalid switch, it raises the exception -- Invalid_Switch and sets Full_Switch to return the invalid switch. -- When Getopt cannot find the parameter associated with a switch, it -- raises Invalid_Parameter, and sets Full_Switch to return the invalid - -- switch character. + -- switch. -- -- Note: in case of ambiguity, e.g. switches a ab abc, then the longest -- matching switch is returned. @@ -416,33 +418,31 @@ package GNAT.Command_Line is function Get_Argument (Do_Expansion : Boolean := False; Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the next element on the command line which is not a switch. - -- This function should not be called before Getopt has returned - -- ASCII.NUL. + -- Returns the next element on the command line that is not a switch. This + -- function should not be called before Getopt has returned ASCII.NUL. -- - -- If Expansion is True, then the parameter on the command line will be - -- considered as a filename with wild cards, and will be expanded. The - -- matching file names will be returned one at a time. When there are no - -- more arguments on the command line, this function returns an empty - -- string. This is useful in non-Unix systems for obtaining normal - -- expansion of wild card references. + -- 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 + -- 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. + -- When there are no more arguments on the command line, this function + -- returns an empty string. function Parameter (Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the parameter associated with the last switch returned by - -- Getopt. If no parameter was associated with the last switch, or no - -- previous call has been made to Get_Argument, raises Invalid_Parameter. - -- If the last switch was associated with an optional argument and this - -- argument was not found on the command line, Parameter returns an empty - -- string. + -- Returns parameter associated with the last switch returned by Getopt. + -- If no parameter was associated with the last switch, or no previous call + -- has been made to Get_Argument, raises Invalid_Parameter. If the last + -- switch was associated with an optional argument and this argument was + -- not found on the command line, Parameter returns an empty string. function Separator (Parser : Opt_Parser := Command_Line_Parser) return Character; -- The separator that was between the switch and its parameter. This is - -- of little use in general, only if you want to know exactly what was on - -- the command line. This is in general a single character, set to - -- ASCII.NUL if the switch and the parameter were concatenated. A space is - -- returned if the switch and its argument were in two separate arguments. + -- useful if you want to know exactly what was on the command line. This + -- is in general a single character, set to ASCII.NUL if the switch and + -- the parameter were concatenated. A space is returned if the switch and + -- its argument were in two separate arguments. type Expansion_Iterator is limited private; -- Type used during expansion of file names @@ -462,16 +462,15 @@ package GNAT.Command_Line is -- Subdirectories of Directory will also be searched, up to one -- hundred levels deep. -- - -- When Start_Expansion has been called, function Expansion should be - -- called repeatedly until it returns an empty string, before + -- When Start_Expansion has been called, function Expansion should + -- be called repeatedly until it returns an empty string, before -- Start_Expansion can be called again with the same Expansion_Iterator -- variable. function Expansion (Iterator : Expansion_Iterator) return String; -- Returns the next file in the directory matching the parameters given -- to Start_Expansion and updates Iterator to point to the next entry. - -- Returns an empty string when there is no more file in the directory - -- and its subdirectories. + -- Returns an empty string when there are no more files. -- -- If Expansion is called again after an empty string has been returned, -- then the exception GNAT.Directory_Operations.Directory_Error is raised. @@ -508,31 +507,31 @@ package GNAT.Command_Line is (Config : in out Command_Line_Configuration; Prefix : String); -- Indicates that all switches starting with the given prefix should be - -- grouped. For instance, for the GNAT compiler we would define "-gnatw" - -- as a prefix, so that "-gnatwu -gnatwv" can be grouped into "-gnatwuv" - -- It is assume that the remaining of the switch ("uv") is a set of - -- characters whose order is irrelevant. In fact, this package will sort - -- them alphabetically. + -- grouped. For instance, for the GNAT compiler we would define "-gnatw" as + -- a prefix, so that "-gnatwu -gnatwv" can be grouped into "-gnatwuv" It is + -- assumed that the remainder of the switch ("uv") is a set of characters + -- whose order is irrelevant. In fact, this package will sort them + -- alphabetically. procedure Define_Switch (Config : in out Command_Line_Configuration; Switch : String); -- Indicates a new switch. The format of this switch follows the getopt -- format (trailing ':', '?', etc for defining a switch with parameters). - -- The switches defined in the command_line_configuration object are used + -- The switches defined in the Command_Line_Configuration object are used -- when ungrouping switches with more that one character after the prefix. procedure Define_Section (Config : in out Command_Line_Configuration; Section : String); - -- Indicates a new switch section. Every switch belonging to the same + -- Indicates a new switch section. All switches belonging to the same -- section are ordered together, preceded by the section. They are placed - -- at the end of the command line (as in 'gnatmake somefile.adb -cargs -g') + -- at the end of the command line (as in "gnatmake somefile.adb -cargs -g") function Get_Switches (Config : Command_Line_Configuration; Switch_Char : Character) return String; - -- Get the switches list as expected by getopt. This list is built using + -- Get the switches list as expected by Getopt. This list is built using -- all switches defined previously via Define_Switch above. procedure Free (Config : in out Command_Line_Configuration); @@ -562,7 +561,7 @@ package GNAT.Command_Line is -- version with Switches. -- -- The parsing of Switches is done through calls to Getopt, by passing - -- Getopt_Description as an argument. (a "*" is automatically prepended so + -- Getopt_Description as an argument. (A "*" is automatically prepended so -- that all switches and command line arguments are accepted). -- -- To properly handle switches that take parameters, you should document @@ -571,8 +570,8 @@ package GNAT.Command_Line is -- Command_Line_Iterator (which might be fine depending on your -- application). -- - -- If the command line has sections (such as -bargs -largs -cargs), then - -- they should be listed in the Sections parameter (as "-bargs -cargs") + -- If the command line has sections (such as -bargs -cargs), then they + -- should be listed in the Sections parameter (as "-bargs -cargs"). -- -- This function can be used to reset Cmd by passing an empty string. @@ -600,16 +599,16 @@ package GNAT.Command_Line is -- to pass "--check=full" to Remove_Switch as well. -- -- A Switch with a parameter will never be grouped with another switch to - -- avoid ambiguities as to who the parameter applies to. + -- avoid ambiguities as to what the parameter applies to. -- -- Separator is the character that goes between the switches and its -- parameter on the command line. If it is set to ASCII.NUL, then no - -- separator is applied, and they are concatenated + -- separator is applied, and they are concatenated. -- -- If the switch is part of a section, then it should be specified so that -- the switch is correctly placed in the command line, and the section -- added if not already present. For example, to add the -g switch into the - -- -cargs section, you need to call (Cmd, "-g", Section => "-cargs") + -- -cargs section, you need to pass (Cmd, "-g", Section => "-cargs"). -- -- Add_Before allows insertion of the switch at the beginning of the -- command line. @@ -667,6 +666,9 @@ package GNAT.Command_Line is -- Remove a switch with a specific parameter. If Parameter is the empty -- string, then only a switch with no parameter will be removed. + procedure Free (Cmd : in out Command_Line); + -- Free the memory used by Cmd + --------------- -- Iteration -- --------------- @@ -703,9 +705,6 @@ package GNAT.Command_Line is procedure Next (Iter : in out Command_Line_Iterator); -- Move to the next switch - procedure Free (Cmd : in out Command_Line); - -- Free the memory used by Cmd - private Max_Depth : constant := 100; diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index 7ef84726dc3..32b914bdfe8 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2008, AdaCore -- +-- Copyright (C) 1998-2010, 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- -- @@ -209,8 +209,8 @@ package GNAT.Directory_Operations is -- Recognize both forms described above. -- -- System_Default - -- Uses either UNIX on Unix and OpenVMS systems, or DOS on Windows and - -- OS/2 depending on the running environment. + -- Uses either UNIX on Unix and OpenVMS systems, or DOS on Windows, + -- depending on the running environment. What about other OS's??? --------------- -- Iterators -- diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb index cc413f7248d..4d1a770822a 100644 --- a/gcc/ada/g-expect-vms.adb +++ b/gcc/ada/g-expect-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, AdaCore -- +-- Copyright (C) 2002-2010, 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- -- @@ -50,6 +50,11 @@ package body GNAT.Expect is Save_Output : File_Descriptor; Save_Error : File_Descriptor; + Expect_Process_Died : constant Expect_Match := -100; + Expect_Internal_Error : constant Expect_Match := -101; + -- Additional possible outputs of Expect_Internal. These are not visible in + -- the spec because the user will never see them. + procedure Expect_Internal (Descriptors : in out Array_Of_Pd; Result : out Expect_Match; @@ -57,11 +62,14 @@ package body GNAT.Expect is Full_Buffer : Boolean); -- Internal function used to read from the process Descriptor. -- - -- Three outputs are possible: + -- Several outputs are possible: -- Result=Expect_Timeout, if no output was available before the timeout -- expired. -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters -- had to be discarded from the internal buffer of Descriptor. + -- Result=Express_Process_Died if one of the processes was terminated. + -- That process's Input_Fd is set to Invalid_FD + -- Result=Express_Internal_Error -- Result=<integer>, indicates how many characters were added to the -- internal buffer. These characters are from indexes -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index @@ -209,7 +217,9 @@ package body GNAT.Expect is Status : out Integer) is begin - Close (Descriptor.Input_Fd); + if Descriptor.Input_Fd /= Invalid_FD then + Close (Descriptor.Input_Fd); + end if; if Descriptor.Error_Fd /= Descriptor.Output_Fd then Close (Descriptor.Error_Fd); @@ -331,10 +341,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- See below + end case; -- Calculate the timeout for the next turn @@ -478,10 +495,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -500,7 +524,10 @@ package body GNAT.Expect is for J in Descriptors'Range loop Descriptors (J) := Regexps (J).Descriptor; - Reinitialize_Buffer (Regexps (J).Descriptor.all); + + if Descriptors (J) /= null then + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end if; end loop; loop @@ -511,25 +538,36 @@ package body GNAT.Expect is -- checking the regexps). for J in Regexps'Range loop - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; + if Regexps (J).Regexp /= null + and then Regexps (J).Descriptor /= null + then + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; end if; end loop; Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -549,21 +587,30 @@ package body GNAT.Expect is N : Integer; type File_Descriptor_Array is - array (Descriptors'Range) of File_Descriptor; + array (0 .. Descriptors'Length - 1) of File_Descriptor; Fds : aliased File_Descriptor_Array; + Fds_Count : Natural := 0; + + Fds_To_Descriptor : array (Fds'Range) of Integer; + -- Maps file descriptor entries from Fds to entries in Descriptors. + -- They do not have the same index when entries in Descriptors are null. - type Integer_Array is array (Descriptors'Range) of Integer; + type Integer_Array is array (Fds'Range) of Integer; Is_Set : aliased Integer_Array; begin for J in Descriptors'Range loop - Fds (J) := Descriptors (J).Output_Fd; + if Descriptors (J) /= null then + Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; + Fds_To_Descriptor (Fds'First + Fds_Count) := J; + Fds_Count := Fds_Count + 1; - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; end if; end loop; @@ -572,19 +619,23 @@ package body GNAT.Expect is -- Buffer used for input. This is allocated only once, not for -- every iteration of the loop + D : Integer; + -- Index in Descriptors + begin -- Loop until we match or we have a timeout loop Num_Descriptors := - Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); + Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); case Num_Descriptors is -- Error? when -1 => - raise Process_Died; + Result := Expect_Internal_Error; + return; -- Timeout? @@ -595,15 +646,17 @@ package body GNAT.Expect is -- Some input when others => - for J in Descriptors'Range loop - if Is_Set (J) = 1 then - Buffer_Size := Descriptors (J).Buffer_Size; + for F in Fds'Range loop + if Is_Set (F) = 1 then + D := Fds_To_Descriptor (F); + + Buffer_Size := Descriptors (D).Buffer_Size; if Buffer_Size = 0 then Buffer_Size := 4096; end if; - N := Read (Descriptors (J).Output_Fd, Buffer'Address, + N := Read (Descriptors (D).Output_Fd, Buffer'Address, Buffer_Size); -- Error or End of file @@ -611,43 +664,46 @@ package body GNAT.Expect is if N <= 0 then -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 - raise Process_Died; + + Descriptors (D).Input_Fd := Invalid_FD; + Result := Expect_Process_Died; + return; else -- If there is no limit to the buffer size - if Descriptors (J).Buffer_Size = 0 then + if Descriptors (D).Buffer_Size = 0 then declare - Tmp : String_Access := Descriptors (J).Buffer; + Tmp : String_Access := Descriptors (D).Buffer; begin if Tmp /= null then - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. Tmp'Length + N); - Descriptors (J).Buffer (1 .. Tmp'Length) := + Descriptors (D).Buffer (1 .. Tmp'Length) := Tmp.all; - Descriptors (J).Buffer + Descriptors (D).Buffer (Tmp'Length + 1 .. Tmp'Length + N) := Buffer (1 .. N); Free (Tmp); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer'Last; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer'Last; else - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. N); - Descriptors (J).Buffer.all := + Descriptors (D).Buffer.all := Buffer (1 .. N); - Descriptors (J).Buffer_Index := N; + Descriptors (D).Buffer_Index := N; end if; end; else -- Add what we read to the buffer - if Descriptors (J).Buffer_Index + N > - Descriptors (J).Buffer_Size + if Descriptors (D).Buffer_Index + N > + Descriptors (D).Buffer_Size then -- If the user wants to know when we have -- read more than the buffer can contain. @@ -660,33 +716,33 @@ package body GNAT.Expect is -- Keep as much as possible from the buffer, -- and forget old characters. - Descriptors (J).Buffer - (1 .. Descriptors (J).Buffer_Size - N) := - Descriptors (J).Buffer - (N - Descriptors (J).Buffer_Size + - Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Size - N; + Descriptors (D).Buffer + (1 .. Descriptors (D).Buffer_Size - N) := + Descriptors (D).Buffer + (N - Descriptors (D).Buffer_Size + + Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index); + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Size - N; end if; -- Keep what we read in the buffer - Descriptors (J).Buffer - (Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index + N) := + Descriptors (D).Buffer + (Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index + N) := Buffer (1 .. N); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Index + N; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Index + N; end if; -- Call each of the output filter with what we -- read. Call_Filters - (Descriptors (J).all, Buffer (1 .. N), Output); + (Descriptors (D).all, Buffer (1 .. N), Output); - Result := Expect_Match (N); + Result := Expect_Match (D); return; end if; end if; @@ -715,6 +771,25 @@ package body GNAT.Expect is (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); end Expect_Out_Match; + ------------------------ + -- First_Dead_Process -- + ------------------------ + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural + is + begin + for R in Regexp'Range loop + if Regexp (R).Descriptor /= null + and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD + then + return R; + end if; + end loop; + + return 0; + end First_Dead_Process; + ----------- -- Flush -- ----------- @@ -770,6 +845,18 @@ package body GNAT.Expect is end loop; end Flush; + ---------- + -- Free -- + ---------- + + procedure Free (Regexp : in out Multiprocess_Regexp) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Process_Descriptor'Class, Process_Descriptor_Access); + begin + Unchecked_Free (Regexp.Descriptor); + Free (Regexp.Regexp); + end Free; + ------------------------ -- Get_Command_Output -- ------------------------ @@ -897,6 +984,15 @@ package body GNAT.Expect is return Descriptor.Pid; end Get_Pid; + ----------------- + -- Has_Process -- + ----------------- + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is + begin + return Regexp /= (Regexp'Range => (null, null)); + end Has_Process; + --------------- -- Interrupt -- --------------- @@ -1023,6 +1119,13 @@ package body GNAT.Expect is Expect_Internal (Descriptors, Result, Timeout => 0, Full_Buffer => False); + + if Result = Expect_Internal_Error + or else Result = Expect_Process_Died + then + raise Process_Died; + end if; + Descriptor.Last_Match_End := Descriptor.Buffer_Index; -- Empty the buffer diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index 6510c310813..c8b368fc58a 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, AdaCore -- +-- Copyright (C) 2000-2010, 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- -- @@ -45,6 +45,11 @@ package body GNAT.Expect is type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; + Expect_Process_Died : constant Expect_Match := -100; + Expect_Internal_Error : constant Expect_Match := -101; + -- Additional possible outputs of Expect_Internal. These are not visible in + -- the spec because the user will never see them. + procedure Expect_Internal (Descriptors : in out Array_Of_Pd; Result : out Expect_Match; @@ -52,11 +57,14 @@ package body GNAT.Expect is Full_Buffer : Boolean); -- Internal function used to read from the process Descriptor. -- - -- Three outputs are possible: + -- Several outputs are possible: -- Result=Expect_Timeout, if no output was available before the timeout -- expired. -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters -- had to be discarded from the internal buffer of Descriptor. + -- Result=Express_Process_Died if one of the processes was terminated. + -- That process's Input_Fd is set to Invalid_FD + -- Result=Express_Internal_Error -- Result=<integer>, indicates how many characters were added to the -- internal buffer. These characters are from indexes -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index @@ -211,7 +219,9 @@ package body GNAT.Expect is Next_Filter : Filter_List; begin - Close (Descriptor.Input_Fd); + if Descriptor.Input_Fd /= Invalid_FD then + Close (Descriptor.Input_Fd); + end if; if Descriptor.Error_Fd /= Descriptor.Output_Fd then Close (Descriptor.Error_Fd); @@ -344,10 +354,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- See below + end case; -- Calculate the timeout for the next turn @@ -493,10 +510,17 @@ package body GNAT.Expect is Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -515,7 +539,10 @@ package body GNAT.Expect is for J in Descriptors'Range loop Descriptors (J) := Regexps (J).Descriptor; - Reinitialize_Buffer (Regexps (J).Descriptor.all); + + if Descriptors (J) /= null then + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end if; end loop; loop @@ -526,25 +553,36 @@ package body GNAT.Expect is -- checking the regexps). for J in Regexps'Range loop - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; + if Regexps (J).Regexp /= null + and then Regexps (J).Descriptor /= null + then + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; end if; end loop; Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; + case N is + when Expect_Internal_Error | Expect_Process_Died => + raise Process_Died; + + when Expect_Timeout | Expect_Full_Buffer => + Result := N; + return; + + when others => + null; -- Continue + end case; end loop; end Expect; @@ -564,21 +602,30 @@ package body GNAT.Expect is N : Integer; type File_Descriptor_Array is - array (Descriptors'Range) of File_Descriptor; + array (0 .. Descriptors'Length - 1) of File_Descriptor; Fds : aliased File_Descriptor_Array; + Fds_Count : Natural := 0; - type Integer_Array is array (Descriptors'Range) of Integer; + Fds_To_Descriptor : array (Fds'Range) of Integer; + -- Maps file descriptor entries from Fds to entries in Descriptors. + -- They do not have the same index when entries in Descriptors are null. + + type Integer_Array is array (Fds'Range) of Integer; Is_Set : aliased Integer_Array; begin for J in Descriptors'Range loop - Fds (J) := Descriptors (J).Output_Fd; + if Descriptors (J) /= null then + Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; + Fds_To_Descriptor (Fds'First + Fds_Count) := J; + Fds_Count := Fds_Count + 1; - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; end if; end loop; @@ -587,19 +634,23 @@ package body GNAT.Expect is -- Buffer used for input. This is allocated only once, not for -- every iteration of the loop + D : Integer; + -- Index in Descriptors + begin -- Loop until we match or we have a timeout loop Num_Descriptors := - Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); + Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); case Num_Descriptors is -- Error? when -1 => - raise Process_Died; + Result := Expect_Internal_Error; + return; -- Timeout? @@ -610,15 +661,17 @@ package body GNAT.Expect is -- Some input when others => - for J in Descriptors'Range loop - if Is_Set (J) = 1 then - Buffer_Size := Descriptors (J).Buffer_Size; + for F in Fds'Range loop + if Is_Set (F) = 1 then + D := Fds_To_Descriptor (F); + + Buffer_Size := Descriptors (D).Buffer_Size; if Buffer_Size = 0 then Buffer_Size := 4096; end if; - N := Read (Descriptors (J).Output_Fd, Buffer'Address, + N := Read (Descriptors (D).Output_Fd, Buffer'Address, Buffer_Size); -- Error or End of file @@ -626,43 +679,46 @@ package body GNAT.Expect is if N <= 0 then -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 - raise Process_Died; + + Descriptors (D).Input_Fd := Invalid_FD; + Result := Expect_Process_Died; + return; else -- If there is no limit to the buffer size - if Descriptors (J).Buffer_Size = 0 then + if Descriptors (D).Buffer_Size = 0 then declare - Tmp : String_Access := Descriptors (J).Buffer; + Tmp : String_Access := Descriptors (D).Buffer; begin if Tmp /= null then - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. Tmp'Length + N); - Descriptors (J).Buffer (1 .. Tmp'Length) := + Descriptors (D).Buffer (1 .. Tmp'Length) := Tmp.all; - Descriptors (J).Buffer + Descriptors (D).Buffer (Tmp'Length + 1 .. Tmp'Length + N) := Buffer (1 .. N); Free (Tmp); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer'Last; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer'Last; else - Descriptors (J).Buffer := + Descriptors (D).Buffer := new String (1 .. N); - Descriptors (J).Buffer.all := + Descriptors (D).Buffer.all := Buffer (1 .. N); - Descriptors (J).Buffer_Index := N; + Descriptors (D).Buffer_Index := N; end if; end; else -- Add what we read to the buffer - if Descriptors (J).Buffer_Index + N > - Descriptors (J).Buffer_Size + if Descriptors (D).Buffer_Index + N > + Descriptors (D).Buffer_Size then -- If the user wants to know when we have -- read more than the buffer can contain. @@ -675,33 +731,33 @@ package body GNAT.Expect is -- Keep as much as possible from the buffer, -- and forget old characters. - Descriptors (J).Buffer - (1 .. Descriptors (J).Buffer_Size - N) := - Descriptors (J).Buffer - (N - Descriptors (J).Buffer_Size + - Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Size - N; + Descriptors (D).Buffer + (1 .. Descriptors (D).Buffer_Size - N) := + Descriptors (D).Buffer + (N - Descriptors (D).Buffer_Size + + Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index); + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Size - N; end if; -- Keep what we read in the buffer - Descriptors (J).Buffer - (Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index + N) := + Descriptors (D).Buffer + (Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index + N) := Buffer (1 .. N); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Index + N; + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Index + N; end if; -- Call each of the output filter with what we -- read. Call_Filters - (Descriptors (J).all, Buffer (1 .. N), Output); + (Descriptors (D).all, Buffer (1 .. N), Output); - Result := Expect_Match (N); + Result := Expect_Match (D); return; end if; end if; @@ -730,6 +786,24 @@ package body GNAT.Expect is (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); end Expect_Out_Match; + ------------------------ + -- First_Dead_Process -- + ------------------------ + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural is + begin + for R in Regexp'Range loop + if Regexp (R).Descriptor /= null + and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD + then + return R; + end if; + end loop; + + return 0; + end First_Dead_Process; + ----------- -- Flush -- ----------- @@ -785,6 +859,18 @@ package body GNAT.Expect is end loop; end Flush; + ---------- + -- Free -- + ---------- + + procedure Free (Regexp : in out Multiprocess_Regexp) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Process_Descriptor'Class, Process_Descriptor_Access); + begin + Unchecked_Free (Regexp.Descriptor); + Free (Regexp.Regexp); + end Free; + ------------------------ -- Get_Command_Output -- ------------------------ @@ -915,6 +1001,15 @@ package body GNAT.Expect is return Descriptor.Pid; end Get_Pid; + ----------------- + -- Has_Process -- + ----------------- + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is + begin + return Regexp /= (Regexp'Range => (null, null)); + end Has_Process; + --------------- -- Interrupt -- --------------- @@ -1136,6 +1231,13 @@ package body GNAT.Expect is Expect_Internal (Descriptors, Result, Timeout => 0, Full_Buffer => False); + + if Result = Expect_Internal_Error + or else Result = Expect_Process_Died + then + raise Process_Died; + end if; + Descriptor.Last_Match_End := Descriptor.Buffer_Index; -- Empty the buffer diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads index 1e50852522a..9a00cf0571e 100644 --- a/gcc/ada/g-expect.ads +++ b/gcc/ada/g-expect.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2009, AdaCore -- +-- Copyright (C) 2000-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -180,16 +180,16 @@ package GNAT.Expect is -- till Expect matches), but this is slower. -- -- If Err_To_Out is True, then the standard error of the spawned process is - -- connected to the standard output. This is the only way to get the - -- Except subprograms to also match on output on standard error. + -- connected to the standard output. This is the only way to get the Except + -- subprograms to also match on output on standard error. -- -- Invalid_Process is raised if the process could not be spawned. procedure Close (Descriptor : in out Process_Descriptor); - -- Terminate the process and close the pipes to it. It implicitly - -- does the 'wait' command required to clean up the process table. - -- This also frees the buffer associated with the process id. Raise - -- Invalid_Process if the process id is invalid. + -- Terminate the process and close the pipes to it. It implicitly does the + -- 'wait' command required to clean up the process table. This also frees + -- the buffer associated with the process id. Raise Invalid_Process if the + -- process id is invalid. procedure Close (Descriptor : in out Process_Descriptor; @@ -247,8 +247,8 @@ package GNAT.Expect is (Descriptor : Process_Descriptor'Class; Str : String; User_Data : System.Address := System.Null_Address); - -- Function called every time new characters are read from or written - -- to the process. + -- Function called every time new characters are read from or written to + -- the process. -- -- Str is a string of all these characters. -- @@ -301,9 +301,9 @@ package GNAT.Expect is Empty_Buffer : Boolean := False); -- Send a string to the file descriptor. -- - -- The string is not formatted in any way, except if Add_LF is True, - -- in which case an ASCII.LF is added at the end, so that Str is - -- recognized as a command by the external process. + -- The string is not formatted in any way, except if Add_LF is True, in + -- which case an ASCII.LF is added at the end, so that Str is recognized + -- as a command by the external process. -- -- If Empty_Buffer is True, any input waiting from the process (or in the -- buffer) is first discarded before the command is sent. The output @@ -330,8 +330,8 @@ package GNAT.Expect is Regexp : String; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Wait till a string matching Fd can be read from Fd, and return 1 - -- if a match was found. + -- Wait till a string matching Fd can be read from Fd, and return 1 if a + -- match was found. -- -- It consumes all the characters read from Fd until a match found, and -- then sets the return values for the subprograms Expect_Out and @@ -402,15 +402,13 @@ package GNAT.Expect is type Regexp_Array is array (Positive range <>) of GNAT.OS_Lib.String_Access; type Pattern_Matcher_Access is access all GNAT.Regpat.Pattern_Matcher; - type Compiled_Regexp_Array is array (Positive range <>) - of Pattern_Matcher_Access; + type Compiled_Regexp_Array is + array (Positive range <>) of Pattern_Matcher_Access; function "+" - (P : GNAT.Regpat.Pattern_Matcher) - return Pattern_Matcher_Access; - -- Allocate some memory for the pattern matcher. - -- This is only a convenience function to help create the array of - -- compiled regular expressions. + (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access; + -- Allocate some memory for the pattern matcher. This is only a convenience + -- function to help create the array of compiled regular expressions. procedure Expect (Descriptor : in out Process_Descriptor; @@ -441,6 +439,7 @@ package GNAT.Expect is Full_Buffer : Boolean := False); -- Same as above, except that you can also access the parenthesis -- groups inside the matching regular expression. + -- -- The first index in Matched must be 0, or Constraint_Error will be -- raised. The index 0 contains the indexes for the whole string that was -- matched, the index 1 contains the indexes for the first parentheses @@ -453,9 +452,8 @@ package GNAT.Expect is Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Same as above, but with precompiled regular expressions. - -- The first index in Matched must be 0, or Constraint_Error will be - -- raised. + -- Same as above, but with precompiled regular expressions. The first index + -- in Matched must be 0, or Constraint_Error will be raised. ------------------------------------------- -- Working on the output (multi-process) -- @@ -465,8 +463,23 @@ package GNAT.Expect is Descriptor : Process_Descriptor_Access; Regexp : Pattern_Matcher_Access; end record; - type Multiprocess_Regexp_Array is array (Positive range <>) - of Multiprocess_Regexp; + + type Multiprocess_Regexp_Array is + array (Positive range <>) of Multiprocess_Regexp; + + procedure Free (Regexp : in out Multiprocess_Regexp); + -- Free the memory occupied by Regexp + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean; + -- Return True if at least one entry in Regexp is non-null, ie there is + -- still at least one process to monitor + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural; + -- Find the first entry in Regexp that corresponds to a dead process that + -- wasn't Free-d yet. This function is called in general when Expect + -- (below) raises the exception Process_Died. This returns 0 if no process + -- has died yet. procedure Expect (Result : out Expect_Match; @@ -474,15 +487,37 @@ package GNAT.Expect is Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Same as above, but for multi processes + -- Same as above, but for multi processes. Any of the entries in + -- Regexps can have a null Descriptor or Regexp. Such entries will + -- simply be ignored. Therefore when a process terminates, you can + -- simply reset its entry. + -- + -- The expect loop would therefore look like: + -- + -- Processes : Multiprocess_Regexp_Array (...) := ...; + -- R : Natural; + -- + -- while Has_Process (Processes) loop + -- begin + -- Expect (Result, Processes, Timeout => -1); + -- ... process output of process Result (output, full buffer,...) + -- + -- exception + -- when Process_Died => + -- -- Free memory + -- R := First_Dead_Process (Processes); + -- Close (Processes (R).Descriptor.all, Status); + -- Free (Processes (R)); + -- end; + -- end loop; procedure Expect (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False); - -- Same as the previous one, but for multiple processes. - -- This procedure finds the first regexp that match the associated process. + -- Same as the previous one, but for multiple processes. This procedure + -- finds the first regexp that match the associated process. ------------------------ -- Getting the output -- @@ -494,8 +529,8 @@ package GNAT.Expect is -- Discard all output waiting from the process. -- -- This output is simply discarded, and no filter is called. This output - -- will also not be visible by the next call to Expect, nor will any - -- output currently buffered. + -- will also not be visible by the next call to Expect, nor will any output + -- currently buffered. -- -- Timeout is the delay for which we wait for output to be available from -- the process. If 0, we only get what is immediately available. @@ -503,13 +538,13 @@ package GNAT.Expect is function Expect_Out (Descriptor : Process_Descriptor) return String; -- Return the string matched by the last Expect call. -- - -- The returned string is in fact the concatenation of all the strings - -- read from the file descriptor up to, and including, the characters - -- that matched the regular expression. + -- The returned string is in fact the concatenation of all the strings read + -- from the file descriptor up to, and including, the characters that + -- matched the regular expression. -- - -- For instance, with an input "philosophic", and a regular expression - -- "hi" in the call to expect, the strings returned the first and second - -- time would be respectively "phi" and "losophi". + -- For instance, with an input "philosophic", and a regular expression "hi" + -- in the call to expect, the strings returned the first and second time + -- would be respectively "phi" and "losophi". function Expect_Out_Match (Descriptor : Process_Descriptor) return String; -- Return the string matched by the last Expect call. @@ -573,10 +608,9 @@ private Pipe3 : in out Pipe_Type; Cmd : String; Args : System.Address); - -- Finish the set up of the pipes while in the child process - -- This also spawns the child process (based on Cmd). - -- On systems that support fork, this procedure is executed inside the - -- newly created process. + -- Finish the set up of the pipes while in the child process This also + -- spawns the child process (based on Cmd). On systems that support fork, + -- this procedure is executed inside the newly created process. type Process_Descriptor is tagged record Pid : aliased Process_Id := Invalid_Pid; @@ -604,7 +638,7 @@ private Args : System.Address); pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp"); -- Executes, in a portable way, the command Cmd (full path must be - -- specified), with the given Args. Args must be an array of string + -- specified), with the given Args, which must be an array of string -- pointers. Note that the first element in Args must be the executable -- name, and the last element must be a null pointer. The returned value -- in Pid is the process ID, or zero if not supported on the platform. diff --git a/gcc/ada/g-mbdira.adb b/gcc/ada/g-mbdira.adb new file mode 100644 index 00000000000..f5fd4dce60d --- /dev/null +++ b/gcc/ada/g-mbdira.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +with Interfaces; use Interfaces; + +package body GNAT.MBBS_Discrete_Random is + + package Calendar renames Ada.Calendar; + + Fits_In_32_Bits : constant Boolean := + Rst'Size < 31 + or else (Rst'Size = 31 + and then Rst'Pos (Rst'First) < 0); + -- This is set True if we do not need more than 32 bits in the result. If + -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit + -- number generated, since if more than 48 bits are required, we split the + -- computation into two separate parts, since the algorithm does not behave + -- above 48 bits. + + -- The way this expression works is that obviously if the size is 31 bits, + -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the + -- range has negative values. It is too conservative in the case that the + -- programmer has set a size greater than the default, e.g. a size of 33 + -- for an integer type with a range of 1..10, but an over-conservative + -- result is OK. The important thing is that the value is only True if + -- we know the result will fit in 32-bits signed. If the value is False + -- when it could be True, the behavior will be correct, just a bit less + -- efficient than it could have been in some unusual cases. + -- + -- One might assume that we could get a more accurate result by testing + -- the lower and upper bounds of the type Rst against the bounds of 32-bit + -- Integer. However, there is no easy way to do that. Why? Because in the + -- relatively rare case where this expresion has to be evaluated at run + -- time rather than compile time (when the bounds are dynamic), we need a + -- type to use for the computation. But the possible range of upper bound + -- values for Rst (remembering the possibility of 64-bit modular types) is + -- from -2**63 to 2**64-1, and no run-time type has a big enough range. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Square_Mod_N (X, N : Int) return Int; + pragma Inline (Square_Mod_N); + -- Computes X**2 mod N avoiding intermediate overflow + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & + ',' & + Int'Image (Of_State.X2) & + ',' & + Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Rst is + S : State renames Gen.Writable.Self.Gen_State; + Temp : Int; + TF : Flt; + + begin + -- Check for flat range here, since we are typically run with checks + -- off, note that in practice, this condition will usually be static + -- so we will not actually generate any code for the normal case. + + if Rst'Last < Rst'First then + raise Constraint_Error; + end if; + + -- Continue with computation if non-flat range + + S.X1 := Square_Mod_N (S.X1, S.P); + S.X2 := Square_Mod_N (S.X2, S.Q); + Temp := S.X2 - S.X1; + + -- Following duplication is not an error, it is a loop unwinding! + + if Temp < 0 then + Temp := Temp + S.Q; + end if; + + if Temp < 0 then + Temp := Temp + S.Q; + end if; + + TF := Offs + (Flt (Temp) * Flt (S.P) + Flt (S.X1)) * S.Scl; + + -- Pathological, but there do exist cases where the rounding implicit + -- in calculating the scale factor will cause rounding to 'Last + 1. + -- In those cases, returning 'First results in the least bias. + + if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then + return Rst'First; + + elsif not Fits_In_32_Bits then + return Rst'Val (Interfaces.Integer_64 (TF)); + + else + return Rst'Val (Int (TF)); + end if; + end Random; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; Initiator : Integer) is + S : State renames Gen.Writable.Self.Gen_State; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + -- Eliminate effects of small Initiators + + S := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator) is + S : State renames Gen.Writable.Self.Gen_State; + Now : constant Calendar.Time := Calendar.Clock; + X1 : Int; + X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now) * 31) + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + S := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; From_State : State) is + begin + Gen.Writable.Self.Gen_State := From_State; + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + begin + return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N))); + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Last : constant Natural := Coded_State'Last; + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Stop <= Last and then Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); + Outs.P := Outs.Q * 2 + 1; + Outs.FP := Flt (Outs.P); + Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks + + if Outs.Q < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; + +end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/g-mbdira.ads b/gcc/ada/g-mbdira.ads new file mode 100644 index 00000000000..c415a24cfcf --- /dev/null +++ b/gcc/ada/g-mbdira.ads @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the 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. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation used in this package was contributed by Robert +-- Eachus. It is based on the work of L. Blum, M. Blum, and M. Shub, SIAM +-- Journal of Computing, Vol 15. No 2, May 1986. The particular choices for P +-- and Q chosen here guarantee a period of 562,085,314,430,582 (about 2**49), +-- and the generated sequence has excellent randomness properties. For further +-- details, see the paper "Fast Generation of Trustworthy Random Numbers", by +-- Robert Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. + +-- Formerly, this package was Ada.Numerics.Discrete_Random. It is retained +-- here in part to allow users to reconstruct number sequences generated +-- by previous versions. + +with Interfaces; + +generic + type Result_Subtype is (<>); + +package GNAT.MBBS_Discrete_Random is + + -- The algorithm used here is reliable from a required statistical point of + -- view only up to 48 bits. We try to behave reasonably in the case of + -- larger types, but we can't guarantee the required properties. So + -- generate a warning for these (slightly) dubious cases. + + pragma Compile_Time_Warning + (Result_Subtype'Size > 48, + "statistical properties not guaranteed for size > 48"); + + -- Basic facilities + + type Generator is limited private; + + function Random (Gen : Generator) return Result_Subtype; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + subtype Int is Interfaces.Integer_32; + subtype Rst is Result_Subtype; + + -- We prefer to use 14 digits for Flt, but some targets are more limited + + type Flt is digits Positive'Min (14, Long_Long_Float'Digits); + + RstF : constant Flt := Flt (Rst'Pos (Rst'First)); + RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); + + Offs : constant Flt := RstF - 0.5; + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F); + + type State is record + X1 : Int := Int (2999 ** 2); + X2 : Int := Int (1439 ** 2); + P : Int := K1; + Q : Int := K2; + FP : Flt := K1F; + Scl : Flt := Scal; + end record; + + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + Gen_State : State; + end record; + +end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/g-mbflra.adb b/gcc/ada/g-mbflra.adb new file mode 100644 index 00000000000..1d59069d112 --- /dev/null +++ b/gcc/ada/g-mbflra.adb @@ -0,0 +1,314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ F L O A T _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +package body GNAT.MBBS_Float_Random is + + ------------------------- + -- Implementation Note -- + ------------------------- + + -- The design of this spec is a bit awkward, as a result of Ada 95 not + -- permitting in-out parameters for function formals (most naturally + -- Generator values would be passed this way). In pure Ada 95, the only + -- solution would be to add a self-referential component to the generator + -- allowing access to the generator object from inside the function. This + -- would work because the generator is limited, which prevents any copy. + + -- This is a bit heavy, so what we do is to use Unrestricted_Access to + -- get a pointer to the state in the passed Generator. This works because + -- Generator is a limited type and will thus always be passed by reference. + + package Calendar renames Ada.Calendar; + + type Pointer is access all State; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int); + + function Euclid (P, Q : Int) return Int; + + function Square_Mod_N (X, N : Int) return Int; + + ------------ + -- Euclid -- + ------------ + + procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is + + XT : Int := 1; + YT : Int := 0; + + procedure Recur + (P, Q : Int; -- a (i-1), a (i) + X, Y : Int; -- x (i), y (i) + XP, YP : in out Int; -- x (i-1), y (i-1) + GCD : out Int); + + procedure Recur + (P, Q : Int; + X, Y : Int; + XP, YP : in out Int; + GCD : out Int) + is + Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _| + XT : Int := X; -- x (i) + YT : Int := Y; -- y (i) + + begin + if P rem Q = 0 then -- while does not divide + GCD := Q; + XP := X; + YP := Y; + else + Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo); + + -- a (i) <== a (i) + -- a (i+1) <-- a (i-1) - q*a (i) + -- x (i+1) <-- x (i-1) - q*x (i) + -- y (i+1) <-- y (i-1) - q*y (i) + -- x (i) <== x (i) + -- y (i) <== y (i) + + XP := XT; + YP := YT; + GCD := Quo; + end if; + end Recur; + + -- Start of processing for Euclid + + begin + Recur (P, Q, 0, 1, XT, YT, GCD); + X := XT; + Y := YT; + end Euclid; + + function Euclid (P, Q : Int) return Int is + X, Y, GCD : Int; + pragma Unreferenced (Y, GCD); + begin + Euclid (P, Q, X, Y, GCD); + return X; + end Euclid; + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2) + & ',' & + Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Uniformly_Distributed is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); + Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); + return + Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X) + mod Genp.Q) * Flt (Genp.P) + + Flt (Genp.X1)) * Genp.Scl); + end Random; + + ----------- + -- Reset -- + ----------- + + -- Version that works from given initiator value + + procedure Reset (Gen : Generator; Initiator : Integer) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + -- Eliminate effects of small initiators + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + end Reset; + + -- Version that works from specific saved state + + procedure Reset (Gen : Generator; From_State : State) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.all := From_State; + end Reset; + + -- Version that works from calendar + + procedure Reset (Gen : Generator) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + Now : constant Calendar.Time := Calendar.Clock; + X1, X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now)) * 31 + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + Temp : constant Flt := Flt (X) * Flt (X); + Div : Int; + + begin + Div := Int (Temp / Flt (N)); + Div := Int (Temp - Flt (Div) * Flt (N)); + + if Div < 0 then + return Div + N; + else + return Div; + end if; + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Last : constant Natural := Coded_State'Last; + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Stop <= Last and then Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.P := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); + Outs.X := Euclid (Outs.P, Outs.Q); + Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks + + if Outs.Q < 31 or else Outs.P < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; +end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/g-mbflra.ads b/gcc/ada/g-mbflra.ads new file mode 100644 index 00000000000..4deac482b52 --- /dev/null +++ b/gcc/ada/g-mbflra.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ F L O A T _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the 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. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation used in this package was contributed by +-- Robert Eachus. It is based on the work of L. Blum, M. Blum, and +-- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The +-- particular choices for P and Q chosen here guarantee a period of +-- 562,085,314,430,582 (about 2**49), and the generated sequence has +-- excellent randomness properties. For further details, see the +-- paper "Fast Generation of Trustworthy Random Numbers", by Robert +-- Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. + +-- Formerly, this package was Ada.Numerics.Float_Random. It is retained +-- here in part to allow users to reconstruct number sequences generated +-- by previous versions. + +with Interfaces; + +package GNAT.MBBS_Float_Random is + + -- Basic facilities + + type Generator is limited private; + + subtype Uniformly_Distributed is Float range 0.0 .. 1.0; + + function Random (Gen : Generator) return Uniformly_Distributed; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + type Int is new Interfaces.Integer_32; + + -- We prefer to use 14 digits for Flt, but some targets are more limited + + type Flt is digits Positive'Min (14, Long_Long_Float'Digits); + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant := 1.0 / (K1F * K2F); + + type State is record + X1 : Int := 2999 ** 2; -- Square mod p + X2 : Int := 1439 ** 2; -- Square mod q + P : Int := K1; + Q : Int := K2; + X : Int := 1; + Scl : Flt := Scal; + end record; + + type Generator is limited record + Gen_State : State; + end record; + +end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb index e96b9cc0c58..b59e1ecec98 100644 --- a/gcc/ada/g-pehage.adb +++ b/gcc/ada/g-pehage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, AdaCore -- +-- Copyright (C) 2002-2010, 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- -- @@ -31,7 +31,9 @@ -- -- ------------------------------------------------------------------------------ -with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Directories; with GNAT.Heap_Sort_G; with GNAT.OS_Lib; use GNAT.OS_Lib; @@ -143,6 +145,9 @@ package body GNAT.Perfect_Hash_Generators is -- Return a string which includes string Str or integer Int preceded by -- leading spaces if required by width W. + function Trim_Trailing_Nuls (Str : String) return String; + -- Return Str with trailing NUL characters removed + Output : File_Descriptor renames GNAT.OS_Lib.Standout; -- Shortcuts @@ -213,6 +218,12 @@ package body GNAT.Perfect_Hash_Generators is procedure Put_Vertex_Table (File : File_Descriptor; Title : String); -- Output a title and a vertex table + function Ada_File_Base_Name (Pkg_Name : String) return String; + -- Return the base file name (i.e. without .ads/.adb extension) for an + -- Ada source file containing the named package, using the standard GNAT + -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we + -- return "parent-child". + ---------------------------------- -- Character Position Selection -- ---------------------------------- @@ -494,11 +505,29 @@ package body GNAT.Perfect_Hash_Generators is return True; end Acyclic; + ------------------------ + -- Ada_File_Base_Name -- + ------------------------ + + function Ada_File_Base_Name (Pkg_Name : String) return String is + begin + -- Convert to lower case, then replace '.' with '-' + + return Result : String := To_Lower (Pkg_Name) do + for J in Result'Range loop + if Result (J) = '.' then + Result (J) := '-'; + end if; + end loop; + end return; + end Ada_File_Base_Name; + --------- -- Add -- --------- procedure Add (C : Character) is + pragma Assert (C /= ASCII.NUL); begin Line (Last + 1) := C; Last := Last + 1; @@ -511,6 +540,11 @@ package body GNAT.Perfect_Hash_Generators is procedure Add (S : String) is Len : constant Natural := S'Length; begin + for J in S'Range loop + pragma Assert (S (J) /= ASCII.NUL); + null; + end loop; + Line (Last + 1 .. Last + Len) := S; Last := Last + Len; end Add; @@ -864,6 +898,11 @@ package body GNAT.Perfect_Hash_Generators is procedure Finalize is begin + if Verbose then + Put (Output, "Finalize"); + New_Line (Output); + end if; + -- Deallocate all the WT components (both initial and reduced -- ones) to avoid memory leaks. @@ -1137,10 +1176,15 @@ package body GNAT.Perfect_Hash_Generators is procedure Initialize (Seed : Natural; K_To_V : Float := Default_K_To_V; - Optim : Optimization := CPU_Time; + Optim : Optimization := Memory_Space; Tries : Positive := Default_Tries) is begin + if Verbose then + Put (Output, "Initialize"); + New_Line (Output); + end if; + -- Deallocate the part of the table concerning the reduced words. -- Initial words are already present in the table. We may have reduced -- words already there because a previous computation failed. We are @@ -1221,6 +1265,16 @@ package body GNAT.Perfect_Hash_Generators is Len : constant Natural := Value'Length; begin + if Verbose then + Put (Output, "Inserting """ & Value & """"); + New_Line (Output); + end if; + + for J in Value'Range loop + pragma Assert (Value (J) /= ASCII.NUL); + null; + end loop; + WT.Set_Last (NK); WT.Table (NK) := New_Word (Value); NK := NK + 1; @@ -1369,7 +1423,7 @@ package body GNAT.Perfect_Hash_Generators is -- Produce -- ------------- - procedure Produce (Pkg_Name : String := Default_Pkg_Name) is + procedure Produce (Pkg_Name : String := Default_Pkg_Name) is File : File_Descriptor; Status : Boolean; @@ -1462,28 +1516,26 @@ package body GNAT.Perfect_Hash_Generators is L : Natural; P : Natural; - PLen : constant Natural := Pkg_Name'Length; - FName : String (1 .. PLen + 4); + FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads"; + -- Initially, the name of the spec file; then modified to be the name of + -- the body file. -- Start of processing for Produce begin - FName (1 .. PLen) := Pkg_Name; - for J in 1 .. PLen loop - if FName (J) in 'A' .. 'Z' then - FName (J) := Character'Val (Character'Pos (FName (J)) - - Character'Pos ('A') - + Character'Pos ('a')); - - elsif FName (J) = '.' then - FName (J) := '-'; - end if; - end loop; - FName (PLen + 1 .. PLen + 4) := ".ads"; + if Verbose then + Put (Output, + "Producing " & Ada.Directories.Current_Directory & "/" & FName); + New_Line (Output); + end if; File := Create_File (FName, Binary); + if File = Invalid_FD then + raise Program_Error with "cannot create: " & FName; + end if; + Put (File, "package "); Put (File, Pkg_Name); Put (File, " is"); @@ -1500,10 +1552,14 @@ package body GNAT.Perfect_Hash_Generators is raise Device_Error; end if; - FName (PLen + 4) := 'b'; + FName (FName'Last) := 'b'; -- Set to body file name File := Create_File (FName, Binary); + if File = Invalid_FD then + raise Program_Error with "cannot create: " & FName; + end if; + Put (File, "with Interfaces; use Interfaces;"); New_Line (File); New_Line (File); @@ -1540,39 +1596,41 @@ package body GNAT.Perfect_Hash_Generators is New_Line (File); - if Opt = CPU_Time then - Put_Int_Matrix - (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T1, T1_Len, T2_Len); - - else - Put_Int_Matrix - (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T1, T1_Len, 0); - end if; + case Opt is + when CPU_Time => + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, T1_Len - 1), + Range_Img (0, T2_Len - 1, Type_Img (256))), + T1, T1_Len, T2_Len); + + when Memory_Space => + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, T1_Len - 1)), + T1, T1_Len, 0); + end case; New_Line (File); - if Opt = CPU_Time then - Put_Int_Matrix - (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T2, T1_Len, T2_Len); - - else - Put_Int_Matrix - (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T2, T1_Len, 0); - end if; + case Opt is + when CPU_Time => + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, T1_Len - 1), + Range_Img (0, T2_Len - 1, Type_Img (256))), + T2, T1_Len, T2_Len); + + when Memory_Space => + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, T1_Len - 1)), + T2, T1_Len, 0); + end case; New_Line (File); @@ -1594,11 +1652,12 @@ package body GNAT.Perfect_Hash_Generators is Put (File, " J : "); - if Opt = CPU_Time then - Put (File, Type_Img (256)); - else - Put (File, "Natural"); - end if; + case Opt is + when CPU_Time => + Put (File, Type_Img (256)); + when Memory_Space => + Put (File, "Natural"); + end case; Put (File, ";"); New_Line (File); @@ -1611,11 +1670,12 @@ package body GNAT.Perfect_Hash_Generators is New_Line (File); Put (File, " J := "); - if Opt = CPU_Time then - Put (File, "C"); - else - Put (File, "Character'Pos"); - end if; + case Opt is + when CPU_Time => + Put (File, "C"); + when Memory_Space => + Put (File, "Character'Pos"); + end case; Put (File, " (S (P (K) + F));"); New_Line (File); @@ -1684,6 +1744,11 @@ package body GNAT.Perfect_Hash_Generators is procedure Put (File : File_Descriptor; Str : String) is Len : constant Natural := Str'Length; begin + for J in Str'Range loop + pragma Assert (Str (J) /= ASCII.NUL); + null; + end loop; + if Write (File, Str'Address, Len) /= Len then raise Program_Error; end if; @@ -1726,13 +1791,12 @@ package body GNAT.Perfect_Hash_Generators is Last := 0; end if; - if Last + Len + 3 > Max then + if Last + Len + 3 >= Max then Flush; end if; if Last = 0 then - Line (Last + 1 .. Last + 5) := " "; - Last := Last + 5; + Add (" "); if F1 <= L1 then if C1 = F1 and then C2 = F2 then @@ -1759,8 +1823,7 @@ package body GNAT.Perfect_Hash_Generators is Add (' '); end if; - Line (Last + 1 .. Last + Len) := S; - Last := Last + Len; + Add (S); if C2 = L2 then Add (')'); @@ -1827,7 +1890,8 @@ package body GNAT.Perfect_Hash_Generators is K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, WT.Table (Initial (J)).all, F1, L1, J, 1, 3, 3); + Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), + F1, L1, J, 1, 3, 3); end loop; end Put_Initial_Keys; @@ -1908,7 +1972,8 @@ package body GNAT.Perfect_Hash_Generators is K := Get_Key (J); Put (File, Image (J, M), F1, L1, J, 1, 3, 1); Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, WT.Table (Reduced (J)).all, F1, L1, J, 1, 3, 3); + Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), + F1, L1, J, 1, 3, 3); end loop; end Put_Reduced_Keys; @@ -2295,7 +2360,8 @@ package body GNAT.Perfect_Hash_Generators is Same_Keys_Sets_Table (J).First .. Same_Keys_Sets_Table (J).Last loop - Put (Output, WT.Table (Reduced (K)).all); + Put (Output, + Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); New_Line (Output); end loop; Put (Output, "--"); @@ -2428,24 +2494,40 @@ package body GNAT.Perfect_Hash_Generators is R : Natural; begin - if Opt = CPU_Time then - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); - S := (S + R) mod NV; - end loop; + case Opt is + when CPU_Time => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); + S := (S + R) mod NV; + end loop; - else - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, 0); - S := (S + R * Character'Pos (Word (J + 1))) mod NV; - end loop; - end if; + when Memory_Space => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, 0); + S := (S + R * Character'Pos (Word (J + 1))) mod NV; + end loop; + end case; return S; end Sum; + ------------------------ + -- Trim_Trailing_Nuls -- + ------------------------ + + function Trim_Trailing_Nuls (Str : String) return String is + begin + for J in reverse Str'Range loop + if Str (J) /= ASCII.NUL then + return Str (Str'First .. J); + end if; + end loop; + + return Str; + end Trim_Trailing_Nuls; + --------------- -- Type_Size -- --------------- diff --git a/gcc/ada/g-pehage.ads b/gcc/ada/g-pehage.ads index e4d0e902df9..dfe926ef782 100644 --- a/gcc/ada/g-pehage.ads +++ b/gcc/ada/g-pehage.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 2002-2010, 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- -- @@ -86,8 +86,9 @@ package GNAT.Perfect_Hash_Generators is -- number of tries. type Optimization is (Memory_Space, CPU_Time); - Default_Optimization : constant Optimization := CPU_Time; - -- Optimize either the memory space or the execution time + -- Optimize either the memory space or the execution time. Note: in + -- practice, the optimization mode has little effect on speed. The tables + -- are somewhat smaller with Memory_Space. Verbose : Boolean := False; -- Output the status of the algorithm. For instance, the tables, the random @@ -97,7 +98,7 @@ package GNAT.Perfect_Hash_Generators is procedure Initialize (Seed : Natural; K_To_V : Float := Default_K_To_V; - Optim : Optimization := CPU_Time; + Optim : Optimization := Memory_Space; Tries : Positive := Default_Tries); -- Initialize the generator and its internal structures. Set the ratio of -- vertices over keys in the random graphs. This value has to be greater @@ -116,7 +117,7 @@ package GNAT.Perfect_Hash_Generators is -- Deallocate the internal structures and the words table procedure Insert (Value : String); - -- Insert a new word in the table + -- Insert a new word into the table. ASCII.NUL characters are not allowed. Too_Many_Tries : exception; -- Raised after Tries unsuccessful runs @@ -124,15 +125,19 @@ package GNAT.Perfect_Hash_Generators is procedure Compute (Position : String := Default_Position); -- Compute the hash function. Position allows to define selection of -- character positions used in the word hash function. Positions can be - -- separated by commas and range like x-y may be used. Character '$' + -- separated by commas and ranges like x-y may be used. Character '$' -- represents the final character of a word. With an empty position, the -- generator automatically produces positions to reduce the memory usage. - -- Raise Too_Many_Tries in case that the algorithm does not succeed in less - -- than Tries attempts (see Initialize). + -- Raise Too_Many_Tries if the algorithm does not succeed within Tries + -- attempts (see Initialize). - procedure Produce (Pkg_Name : String := Default_Pkg_Name); + procedure Produce (Pkg_Name : String := Default_Pkg_Name); -- Generate the hash function package Pkg_Name. This package includes the - -- minimal perfect Hash function. + -- minimal perfect Hash function. The output is placed in the current + -- directory, in files X.ads and X.adb, where X is the standard GNAT file + -- name for a package named Pkg_Name. + + ---------------------------------------------------------------- -- The routines and structures defined below allow producing the hash -- function using a different way from the procedure above. The procedure diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb index a89b09b8d08..3432f86b3d9 100644 --- a/gcc/ada/g-sercom-linux.adb +++ b/gcc/ada/g-sercom-linux.adb @@ -158,8 +158,8 @@ package body GNAT.Serial_Communications is Buffer : out Stream_Element_Array; Last : out Stream_Element_Offset) is - Len : constant int := Buffer'Length; - Res : int; + Len : constant size_t := Buffer'Length; + Res : ssize_t; begin if Port.H = null then @@ -264,8 +264,8 @@ package body GNAT.Serial_Communications is (Port : in out Serial_Port; Buffer : Stream_Element_Array) is - Len : constant int := Buffer'Length; - Res : int; + Len : constant size_t := Buffer'Length; + Res : ssize_t; begin if Port.H = null then @@ -273,11 +273,12 @@ package body GNAT.Serial_Communications is end if; Res := write (int (Port.H.all), Buffer'Address, Len); - pragma Assert (Res = Len); if Res = -1 then Raise_Error ("write failed"); end if; + + pragma Assert (size_t (Res) = Len); end Write; ----------- diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 2a3fe6f39af..b75c525202f 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, 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- -- @@ -273,7 +273,8 @@ package body GNAT.Sockets is function Is_Open (S : Selector_Type) return Boolean; -- Return True for an "open" Selector_Type object, i.e. one for which - -- Create_Selector has been called and Close_Selector has not been called. + -- Create_Selector has been called and Close_Selector has not been called, + -- or the null selector. --------- -- "+" -- @@ -294,6 +295,10 @@ package body GNAT.Sockets is begin if not Is_Open (Selector) then raise Program_Error with "closed selector"; + + elsif Selector.Is_Null then + raise Program_Error with "null selector"; + end if; -- Send one byte to unblock select system call @@ -465,7 +470,7 @@ package body GNAT.Sockets is -------------------- procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; Status : out Selector_Status; @@ -482,7 +487,7 @@ package body GNAT.Sockets is -------------------- procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; E_Socket_Set : in out Socket_Set_Type; @@ -491,7 +496,7 @@ package body GNAT.Sockets is is Res : C.int; Last : C.int; - RSig : constant Socket_Type := Selector.R_Sig_Socket; + RSig : Socket_Type := No_Socket; TVal : aliased Timeval; TPtr : Timeval_Access; @@ -511,9 +516,12 @@ package body GNAT.Sockets is TPtr := TVal'Unchecked_Access; end if; - -- Add read signalling socket + -- Add read signalling socket, if present - Set (R_Socket_Set, RSig); + if not Selector.Is_Null then + RSig := Selector.R_Sig_Socket; + Set (R_Socket_Set, RSig); + end if; Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last), C.int (W_Socket_Set.Last)), @@ -540,7 +548,7 @@ package body GNAT.Sockets is -- If Select was resumed because of read signalling socket, read this -- data and remove socket from set. - if Is_Set (R_Socket_Set, RSig) then + if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then Clear (R_Socket_Set, RSig); Res := Signalling_Fds.Read (C.int (RSig)); @@ -585,10 +593,9 @@ package body GNAT.Sockets is procedure Close_Selector (Selector : in out Selector_Type) is begin - if not Is_Open (Selector) then - - -- Selector already in closed state: nothing to do + -- Nothing to do if selector already in closed state + if Selector.Is_Null or else not Is_Open (Selector) then return; end if; @@ -1425,14 +1432,19 @@ package body GNAT.Sockets is function Is_Open (S : Selector_Type) return Boolean is begin - -- Either both controlling socket descriptors are valid (case of an - -- open selector) or neither (case of a closed selector). + if S.Is_Null then + return True; + + else + -- Either both controlling socket descriptors are valid (case of an + -- open selector) or neither (case of a closed selector). - pragma Assert ((S.R_Sig_Socket /= No_Socket) - = - (S.W_Sig_Socket /= No_Socket)); + pragma Assert ((S.R_Sig_Socket /= No_Socket) + = + (S.W_Sig_Socket /= No_Socket)); - return S.R_Sig_Socket /= No_Socket; + return S.R_Sig_Socket /= No_Socket; + end if; end Is_Open; ------------ diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index d81f7da6b89..55330bd784a 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, 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- -- @@ -422,6 +422,11 @@ package GNAT.Sockets is type Selector_Access is access all Selector_Type; -- Selector objects are used to wait for i/o events to occur on sockets + Null_Selector : constant Selector_Type; + -- The Null_Selector can be used in place of a normal selector without + -- having to call Create_Selector if the use of Abort_Selector is not + -- required. + -- Timeval_Duration is a subtype of Standard.Duration because the full -- range of Standard.Duration cannot be represented in the equivalent C -- structure. Moreover, negative values are not allowed to avoid system @@ -664,33 +669,33 @@ package GNAT.Sockets is -- with a socket. Options may exist at multiple protocol levels in the -- communication stack. Socket_Level is the uppermost socket level. - type Level_Type is ( - Socket_Level, - IP_Protocol_For_IP_Level, - IP_Protocol_For_UDP_Level, - IP_Protocol_For_TCP_Level); + type Level_Type is + (Socket_Level, + IP_Protocol_For_IP_Level, + IP_Protocol_For_UDP_Level, + IP_Protocol_For_TCP_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. - type Option_Name is ( - 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, -- Join a multicast group - Drop_Membership, -- Leave a multicast group - Multicast_If, -- Set default out interface for multicast packets - Multicast_TTL, -- Set the time-to-live of sent multicast packets - Multicast_Loop, -- Sent multicast packets are looped to local 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 + type Option_Name is + (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, -- Join a multicast group + Drop_Membership, -- Leave a multicast group + Multicast_If, -- Set default out interface for multicast packets + Multicast_TTL, -- Set the time-to-live of sent multicast packets + Multicast_Loop, -- Sent multicast packets are looped to local 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 type Option_Type (Name : Option_Name := Keep_Alive) is record case Name is @@ -740,8 +745,8 @@ package GNAT.Sockets is -- socket options in that they are not specific to sockets but are -- available for any device. - type Request_Name is ( - Non_Blocking_IO, -- Cause a caller not to wait on blocking operations. + type Request_Name is + (Non_Blocking_IO, -- Cause a caller not to wait on blocking operations N_Bytes_To_Read); -- Return the number of bytes available to read type Request_Type (Name : Request_Name := Non_Blocking_IO) is record @@ -1067,7 +1072,7 @@ package GNAT.Sockets is -- the situation where a change to the monitored sockets set must be made. procedure Create_Selector (Selector : out Selector_Type); - -- Create a new selector + -- Initialize (open) a new selector procedure Close_Selector (Selector : in out Selector_Type); -- Close Selector and all internal descriptors associated; deallocate any @@ -1077,7 +1082,7 @@ package GNAT.Sockets is -- already closed. procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; Status : out Selector_Status; @@ -1088,15 +1093,17 @@ package GNAT.Sockets is -- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was -- ready after a Timeout expiration. Status is set to Aborted if an abort -- signal has been received while checking socket status. + -- -- Note that two different Socket_Set_Type objects must be passed as -- R_Socket_Set and W_Socket_Set (even if they denote the same set of -- Sockets), or some event may be lost. + -- -- Socket_Error is raised when the select(2) system call returns an -- error condition, or when a read error occurs on the signalling socket -- used for the implementation of Abort_Selector. procedure Check_Selector - (Selector : in out Selector_Type; + (Selector : Selector_Type; R_Socket_Set : in out Socket_Set_Type; W_Socket_Set : in out Socket_Set_Type; E_Socket_Set : in out Socket_Set_Type; @@ -1108,7 +1115,8 @@ package GNAT.Sockets is -- different objects. procedure Abort_Selector (Selector : Selector_Type); - -- Send an abort signal to the selector + -- Send an abort signal to the selector. The Selector may not be the + -- Null_Selector. type Fd_Set is private; -- ??? This type must not be used directly, it needs to be visible because @@ -1124,14 +1132,28 @@ private type Socket_Type is new Integer; No_Socket : constant Socket_Type := -1; - type Selector_Type is limited record - R_Sig_Socket : Socket_Type := No_Socket; - W_Sig_Socket : Socket_Type := No_Socket; - -- Signalling sockets used to abort a select operation + -- A selector is either a null selector, which is always "open" and can + -- never be aborted, or a regular selector, which is created "closed", + -- becomes "open" when Create_Selector is called, and "closed" again when + -- Close_Selector is called. + + type Selector_Type (Is_Null : Boolean := False) is limited record + case Is_Null is + when True => + null; + + when False => + R_Sig_Socket : Socket_Type := No_Socket; + W_Sig_Socket : Socket_Type := No_Socket; + -- Signalling sockets used to abort a select operation + + end case; end record; pragma Volatile (Selector_Type); + Null_Selector : constant Selector_Type := (Is_Null => True); + type Fd_Set is new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_fd_set); for Fd_Set'Alignment use Interfaces.C.long'Alignment; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index 49df16363b3..727a69ddba9 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,8 +37,11 @@ -- This version is for NT -with Interfaces.C.Strings; use Interfaces.C.Strings; -with System; use System; +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Conversion; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; package body GNAT.Sockets.Thin is @@ -269,8 +272,14 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is + use type C.size_t; + + Fill : constant Boolean := + (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; + -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors + Res : C.int; Count : C.int := 0; @@ -281,25 +290,81 @@ package body GNAT.Sockets.Thin is for Iovec'Address use MH.Msg_Iov; pragma Import (Ada, Iovec); + Iov_Index : Integer; + Current_Iovec : Vector_Element; + + function To_Access is new Ada.Unchecked_Conversion + (System.Address, Stream_Element_Reference); + pragma Warnings (Off, Stream_Element_Reference); + + Req : Request_Type (Name => N_Bytes_To_Read); + begin -- Windows does not provide an implementation of recvmsg(). The spec for -- WSARecvMsg() is incompatible with the data types we define, and is - -- not available in all versions of Windows. So, we use C_Recv instead. + -- available starting with Windows Vista and Server 2008 only. So, + -- we use C_Recv instead. - for J in Iovec'Range loop - Res := C_Recv - (S, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - Flags); + -- Check how much data are available + + Control_Socket (Socket_Type (S), Req); + + -- Fill the vectors + + Iov_Index := -1; + Current_Iovec := (Base => null, Length => 0); + + loop + if Current_Iovec.Length = 0 then + Iov_Index := Iov_Index + 1; + exit when Iov_Index > Integer (Iovec'Last); + Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); + end if; + + Res := + C_Recv + (S, + Current_Iovec.Base.all'Address, + C.int (Current_Iovec.Length), + Flags); if Res < 0 then - return ssize_t (Res); + return System.CRTL.ssize_t (Res); + + elsif Res = 0 and then not Fill then + exit; + else + pragma Assert (Stream_Element_Count (Res) <= Current_Iovec.Length); + Count := Count + Res; + Current_Iovec.Length := + Current_Iovec.Length - Stream_Element_Count (Res); + Current_Iovec.Base := + To_Access (Current_Iovec.Base.all'Address + + Storage_Offset (Res)); + + -- If all the data that was initially available read, do not + -- attempt to receive more, since this might block, or merge data + -- from successive datagrams for a datagram-oriented socket. We + -- still try to receive more if we need to fill all vectors + -- (MSG_WAITALL flag is set). + + exit when Natural (Count) >= Req.Size + and then + + -- Either we are not in fill mode + + (not Fill + + -- Or else last vector filled + + or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last + and then Current_Iovec.Length = 0)); end if; end loop; - return ssize_t (Count); + + return System.CRTL.ssize_t (Count); end C_Recvmsg; -------------- @@ -322,8 +387,8 @@ package body GNAT.Sockets.Thin is Last : aliased C.int; begin - -- Asynchronous connection failures are notified in the exception fd set - -- instead of the write fd set. To ensure POSIX compatibility, copy + -- Asynchronous connection failures are notified in the exception fd + -- set instead of the write fd set. To ensure POSIX compatibility, copy -- write fd set into exception fd set. Once select() returns, check any -- socket present in the exception fd set and peek at incoming -- out-of-band data. If the test is not successful, and the socket is @@ -369,10 +434,11 @@ package body GNAT.Sockets.Thin is -- Check out-of-band data - Length := C_Recvfrom - (S, Buffer'Address, 1, Flag, - From => System.Null_Address, - Fromlen => Fromlen'Unchecked_Access); + Length := + C_Recvfrom + (S, Buffer'Address, 1, Flag, + From => System.Null_Address, + Fromlen => Fromlen'Unchecked_Access); -- Is Fromlen necessary if From is Null_Address??? -- If the signal is not an out-of-band data, then it @@ -404,8 +470,10 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is + use type C.size_t; + Res : C.int; Count : C.int := 0; @@ -419,25 +487,31 @@ package body GNAT.Sockets.Thin is begin -- Windows does not provide an implementation of sendmsg(). The spec for -- WSASendMsg() is incompatible with the data types we define, and is - -- not available in all versions of Windows. So, we'll use C_Sendto - -- instead. + -- available starting with Windows Vista and Server 2008 only. So + -- use C_Sendto instead. for J in Iovec'Range loop - Res := C_Sendto - (S, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - Flags => Flags, - To => MH.Msg_Name, - Tolen => C.int (MH.Msg_Namelen)); + Res := + C_Sendto + (S, + Iovec (J).Base.all'Address, + C.int (Iovec (J).Length), + Flags => Flags, + To => MH.Msg_Name, + Tolen => C.int (MH.Msg_Namelen)); if Res < 0 then - return ssize_t (Res); + return System.CRTL.ssize_t (Res); else Count := Count + Res; end if; + + -- Exit now if the buffer is not fully transmitted + + exit when Stream_Element_Count (Res) < Iovec (J).Length; end loop; - return ssize_t (Count); + + return System.CRTL.ssize_t (Count); end C_Sendmsg; -------------- @@ -459,13 +533,12 @@ package body GNAT.Sockets.Thin is package body Host_Error_Messages is -- On Windows, socket and host errors share the same code space, and - -- error messages are provided by Socket_Error_Message. The default - -- separate body for Host_Error_Messages is therefore not used in - -- this case. + -- error messages are provided by Socket_Error_Message, so the default + -- separate body for Host_Error_Messages is not used in this case. function Host_Error_Message (H_Errno : Integer) return C.Strings.chars_ptr - renames Socket_Error_Message; + renames Socket_Error_Message; end Host_Error_Messages; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index 6d851e17cb4..bc1f256497e 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -42,6 +42,7 @@ with Interfaces.C.Strings; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -49,10 +50,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer; -- Returns last socket error number @@ -146,7 +144,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -158,7 +156,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index b9e23ecbfb5..1331821446f 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -292,7 +292,7 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -314,7 +314,7 @@ package body GNAT.Sockets.Thin is GNAT_Msg := Msghdr (VMS_Msg); - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Recvmsg; --------------- @@ -324,7 +324,7 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -346,7 +346,7 @@ package body GNAT.Sockets.Thin is GNAT_Msg := Msghdr (VMS_Msg); - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Sendmsg; -------------- diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index a1bb487e136..3a443ac652d 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -43,6 +43,7 @@ with GNAT.OS_Lib; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -52,10 +53,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -149,7 +147,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -161,7 +159,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index e6a8ee60644..8c119661ed4 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -309,7 +309,7 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -323,7 +323,7 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Recvmsg; --------------- @@ -333,7 +333,7 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is Res : C.int; @@ -347,7 +347,7 @@ package body GNAT.Sockets.Thin is delay Quantum; end loop; - return ssize_t (Res); + return System.CRTL.ssize_t (Res); end C_Sendmsg; -------------- diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 4f92b3a8143..64cc87668ce 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -43,6 +43,7 @@ with GNAT.OS_Lib; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -50,10 +51,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -147,7 +145,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -159,7 +157,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb index ca797631b08..301d8be45d4 100644 --- a/gcc/ada/g-socthi.adb +++ b/gcc/ada/g-socthi.adb @@ -95,13 +95,13 @@ package body GNAT.Sockets.Thin is function Syscall_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; pragma Import (C, Syscall_Recvmsg, "recvmsg"); function Syscall_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; pragma Import (C, Syscall_Sendmsg, "sendmsg"); function Syscall_Sendto @@ -307,15 +307,15 @@ package body GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is - Res : ssize_t; + Res : System.CRTL.ssize_t; begin loop Res := Syscall_Recvmsg (S, Msg, Flags); exit when SOSC.Thread_Blocking_IO - or else Res /= ssize_t (Failure) + or else Res /= System.CRTL.ssize_t (Failure) or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; @@ -331,15 +331,15 @@ package body GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t + Flags : C.int) return System.CRTL.ssize_t is - Res : ssize_t; + Res : System.CRTL.ssize_t; begin loop Res := Syscall_Sendmsg (S, Msg, Flags); exit when SOSC.Thread_Blocking_IO - or else Res /= ssize_t (Failure) + or else Res /= System.CRTL.ssize_t (Failure) or else Non_Blocking_Socket (S) or else Errno /= SOSC.EWOULDBLOCK; delay Quantum; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index 1f103e89a74..32013c35e7f 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -43,6 +43,7 @@ with GNAT.OS_Lib; with GNAT.Sockets.Thin_Common; with System; +with System.CRTL; package GNAT.Sockets.Thin is @@ -54,10 +55,7 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type C.size_t; - type ssize_t is range -(2 ** (C.size_t'Size - 1)) - .. +(2 ** (C.size_t'Size - 1) - 1); - -- Signed type of the same size as size_t + use type System.CRTL.ssize_t; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; -- Returns last socket error number @@ -148,7 +146,7 @@ package GNAT.Sockets.Thin is function C_Recvmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Select (Nfds : C.int; @@ -160,7 +158,7 @@ package GNAT.Sockets.Thin is function C_Sendmsg (S : C.int; Msg : System.Address; - Flags : C.int) return ssize_t; + Flags : C.int) return System.CRTL.ssize_t; function C_Sendto (S : C.int; diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads index 63a6a228806..6ffd06631e7 100644 --- a/gcc/ada/g-sothco.ads +++ b/gcc/ada/g-sothco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, AdaCore -- +-- Copyright (C) 2008-2010, 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- -- @@ -294,18 +294,18 @@ package GNAT.Sockets.Thin_Common is H_Errnop : not null access C.int) return C.int; function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; function C_Getservbyport - (Port : C.int; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; ------------------------------------ -- Scatter/gather vector handling -- diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index c5c07f105e2..a85697507f3 100644 --- a/gcc/ada/g-spipat.adb +++ b/gcc/ada/g-spipat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, AdaCore -- +-- Copyright (C) 1998-2009, 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- -- @@ -2793,9 +2793,8 @@ package body GNAT.Spitbol.Patterns is (Subject : VString; Pat : Pattern) return Boolean is - S : String_Access; + S : Big_String_Access; L : Natural; - Start : Natural; Stop : Natural; pragma Unreferenced (Stop); @@ -2838,7 +2837,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2867,7 +2866,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2892,7 +2891,7 @@ package body GNAT.Spitbol.Patterns is (Subject : VString; Pat : Pattern) is - S : String_Access; + S : Big_String_Access; L : Natural; Start : Natural; @@ -2933,7 +2932,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2958,7 +2957,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -2980,7 +2979,7 @@ package body GNAT.Spitbol.Patterns is Pat : PString) return Boolean is Pat_Len : constant Natural := Pat'Length; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3038,7 +3037,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3067,7 +3066,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3092,7 +3091,7 @@ package body GNAT.Spitbol.Patterns is (Subject : VString; Pat : PString) is - S : String_Access; + S : Big_String_Access; L : Natural; Start : Natural; @@ -3133,7 +3132,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3158,7 +3157,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3182,7 +3181,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3213,7 +3212,7 @@ package body GNAT.Spitbol.Patterns is is Start : Natural; Stop : Natural; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3362,7 +3361,7 @@ package body GNAT.Spitbol.Patterns is (Result : in out Match_Result; Replace : VString) is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3955,7 +3954,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -3975,7 +3974,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4142,7 +4141,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4163,7 +4162,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4210,7 +4209,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4231,7 +4230,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4376,7 +4375,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4397,7 +4396,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4440,7 +4439,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4459,7 +4458,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4682,7 +4681,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -4708,7 +4707,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -4809,7 +4808,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -4829,7 +4828,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5354,7 +5353,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5376,7 +5375,7 @@ package body GNAT.Spitbol.Patterns is when PC_Any_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5563,7 +5562,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5585,7 +5584,7 @@ package body GNAT.Spitbol.Patterns is when PC_Break_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5637,7 +5636,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5659,7 +5658,7 @@ package body GNAT.Spitbol.Patterns is when PC_BreakX_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5826,7 +5825,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5848,7 +5847,7 @@ package body GNAT.Spitbol.Patterns is when PC_NotAny_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5896,7 +5895,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -5916,7 +5915,7 @@ package body GNAT.Spitbol.Patterns is when PC_NSpan_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -6172,7 +6171,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -6199,7 +6198,7 @@ package body GNAT.Spitbol.Patterns is when PC_Span_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; P : Natural; @@ -6314,7 +6313,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VF => declare U : constant VString := Node.VF.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -6335,7 +6334,7 @@ package body GNAT.Spitbol.Patterns is when PC_String_VP => declare U : constant VString := Node.VP.all; - S : String_Access; + S : Big_String_Access; L : Natural; begin diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb index 5b5e2a78e04..4769fa3025d 100644 --- a/gcc/ada/g-spitbo.adb +++ b/gcc/ada/g-spitbo.adb @@ -135,7 +135,7 @@ package body GNAT.Spitbol is ------- function N (Str : VString) return Integer is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Str, S, L); @@ -147,7 +147,7 @@ package body GNAT.Spitbol is -------------------- function Reverse_String (Str : VString) return VString is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -177,7 +177,7 @@ package body GNAT.Spitbol is end Reverse_String; procedure Reverse_String (Str : in out VString) is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -191,7 +191,7 @@ package body GNAT.Spitbol is Result (J) := S (L + 1 - J); end loop; - Set_String (Str, Result); + Set_Unbounded_String (Str, Result); end; end Reverse_String; @@ -284,7 +284,7 @@ package body GNAT.Spitbol is Start : Positive; Len : Natural) return VString is - S : String_Access; + S : Big_String_Access; L : Natural; begin @@ -413,7 +413,7 @@ package body GNAT.Spitbol is if Elmt.Name /= null then loop - Set_String (TA (P).Name, Elmt.Name.all); + Set_Unbounded_String (TA (P).Name, Elmt.Name.all); TA (P).Value := Elmt.Value; P := P + 1; Elmt := Elmt.Next; @@ -458,7 +458,7 @@ package body GNAT.Spitbol is end Delete; procedure Delete (T : in out Table; Name : VString) is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); @@ -584,7 +584,7 @@ package body GNAT.Spitbol is end Get; function Get (T : Table; Name : VString) return Value_Type is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); @@ -625,7 +625,7 @@ package body GNAT.Spitbol is end Present; function Present (T : Table; Name : VString) return Boolean is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); @@ -661,7 +661,7 @@ package body GNAT.Spitbol is --------- procedure Set (T : in out Table; Name : VString; Value : Value_Type) is - S : String_Access; + S : Big_String_Access; L : Natural; begin Get_String (Name, S, L); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 9b6a308ae43..095ae08bbad 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -144,6 +144,7 @@ GNAT_ADA_OBJS = \ ada/exp_aggr.o \ ada/exp_atag.o \ ada/exp_attr.o \ + ada/exp_cg.o \ ada/exp_ch11.o \ ada/exp_ch12.o \ ada/exp_ch13.o \ @@ -188,6 +189,8 @@ GNAT_ADA_OBJS = \ ada/gnatvsn.o \ ada/hlo.o \ ada/hostparm.o \ + ada/i-c.o \ + ada/i-cstrea.o \ ada/impunit.o \ ada/inline.o \ ada/interfac.o \ @@ -263,6 +266,7 @@ GNAT_ADA_OBJS = \ ada/s-wchcon.o \ ada/s-wchjis.o \ ada/scans.o \ + ada/scil_ll.o \ ada/scn.o \ ada/scng.o \ ada/scos.o \ @@ -439,7 +443,9 @@ GNATBIND_OBJS = \ ada/s-wchjis.o \ ada/scng.o \ ada/scans.o \ + ada/scil_ll.o \ ada/sdefault.o \ + ada/sem_aux.o \ ada/sinfo.o \ ada/sinput.o \ ada/sinput-c.o \ @@ -561,15 +567,19 @@ ada/doctools/xgnatugn$(build_exeext): ada/xgnatugn.adb $(CP) $^ ada/doctools cd ada/doctools && $(GNATMAKE) -q xgnatugn -# Note that doc/gnat_ugn.texi does not depend on xgnatugn -# being built so we can distribute a pregenerated doc/gnat_ugn.info +# Note that doc/gnat_ugn.texi and doc/projects.texi do not depend on +# xgnatugn being built so we can distribute a pregenerated doc/gnat_ugn.info doc/gnat_ugn.texi: $(srcdir)/ada/gnat_ugn.texi $(srcdir)/ada/ug_words \ - $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(MAKE) ada/doctools/xgnatugn$(build_exeext) + doc/projects.texi $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi ada/doctools/xgnatugn unw $(srcdir)/ada/gnat_ugn.texi \ $(srcdir)/ada/ug_words doc/gnat_ugn.texi +doc/projects.texi: $(srcdir)/ada/projects.texi + $(MAKE) ada/doctools/xgnatugn$(build_exeext) + ada/doctools/xgnatugn unw $(srcdir)/ada/projects.texi \ + $(srcdir)/ada/ug_words doc/projects.texi + doc/gnat_ugn.info: doc/gnat_ugn.texi \ $(gcc_docdir)/include/fdl.texi $(gcc_docdir)/include/gcc-common.texi \ gcc-vers.texi @@ -1234,7 +1244,7 @@ ada/decl.o : ada/gcc-interface/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ ada/misc.o : ada/gcc-interface/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_H) $(TREE_H) $(DIAGNOSTIC_H) $(TARGET_H) $(FUNCTION_H) \ - $(FLAGS_H) debug.h toplev.h $(EXCEPT_H) langhooks.h \ + $(FLAGS_H) debug.h toplev.h langhooks.h \ $(LANGHOOKS_DEF_H) opts.h options.h $(TREE_INLINE_H) $(PLUGIN_H) \ ada/gcc-interface/ada.h ada/adadecode.h ada/types.h ada/atree.h \ ada/elists.h ada/namet.h ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h \ @@ -1250,7 +1260,7 @@ ada/targtyps.o : ada/gcc-interface/targtyps.c $(CONFIG_H) $(SYSTEM_H) \ $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ ada/trans.o : ada/gcc-interface/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ - $(TM_H) $(TREE_H) $(FLAGS_H) output.h tree-iterator.h \ + $(TM_H) $(TREE_H) $(FLAGS_H) output.h tree-iterator.h $(TREE_FLOW_H) \ $(GIMPLE_H) ada/gcc-interface/ada.h ada/adadecode.h ada/types.h \ ada/atree.h ada/elists.h ada/namet.h ada/nlists.h ada/snames.h \ ada/stringt.h ada/uintp.h ada/urealp.h ada/fe.h ada/sinfo.h ada/einfo.h \ @@ -1263,8 +1273,9 @@ ada/utils.o : ada/gcc-interface/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TARGET_H) function.h langhooks.h $(CGRAPH_H) \ $(TREE_DUMP_H) $(TREE_INLINE_H) tree-iterator.h \ ada/gcc-interface/ada.h ada/types.h ada/atree.h ada/elists.h ada/namet.h \ - ada/nlists.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h ada/einfo.h \ - $(ADA_TREE_H) ada/gcc-interface/gigi.h gt-ada-utils.h gtype-ada.h + ada/nlists.h ada/snames.h ada/stringt.h ada/uintp.h ada/fe.h ada/sinfo.h \ + ada/einfo.h $(ADA_TREE_H) ada/gcc-interface/gigi.h gt-ada-utils.h \ + gtype-ada.h $(COMPILER) -c $(ALL_COMPILERFLAGS) -I.. $(ALL_CPPFLAGS) $< -o $@ ada/utils2.o : ada/gcc-interface/utils2.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ @@ -1464,29 +1475,33 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ - ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-load.ads ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/rtsfind.adb ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads ada/exp_dist.ads \ + ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ + ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \ + ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/validsw.ads + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ + ada/widechar.ads ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1522,20 +1537,19 @@ ada/cstand.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_mech.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads @@ -1561,7 +1575,8 @@ ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/elists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/elists.ads \ @@ -1588,16 +1603,16 @@ ada/errout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/fname.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/nlists.adb ada/opt.ads ada/output.ads ada/scans.ads ada/sem_aux.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1650,18 +1665,18 @@ ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ ada/sem_dist.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ ada/widechar.ads @@ -1705,20 +1720,36 @@ ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + +ada/exp_cg.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ + ada/elists.adb ada/exp_cg.ads ada/exp_cg.adb ada/exp_dbug.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_disp.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1773,7 +1804,7 @@ ada/exp_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \ ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1807,24 +1838,25 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \ - ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ + ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ + ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch4.adb ada/exp_ch6.ads \ @@ -1832,23 +1864,28 @@ ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads \ + ada/inline.ads ada/interfac.ads ada/itypes.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ + ada/par_sco.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1868,20 +1905,19 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads \ ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1901,21 +1937,21 @@ ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_mech.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ ada/widechar.ads @@ -1933,17 +1969,16 @@ ada/exp_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ ada/sem_aux.ads ada/sem_ch3.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1956,16 +1991,15 @@ ada/exp_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ ada/rtsfind.ads ada/sem.ads ada/sem_aux.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1982,9 +2016,9 @@ ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch11.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch11.ads ada/sem_ch6.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elab.ads ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ @@ -2012,9 +2046,9 @@ ada/exp_code.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ @@ -2050,31 +2084,31 @@ ada/exp_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads \ - ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads ada/exp_tss.adb \ - ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ - ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ - ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch6.ads \ + ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads \ + ada/exp_tss.adb ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ + ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \ - ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2086,9 +2120,9 @@ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads \ - ada/sem_dist.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch3.ads \ + ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_util.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ @@ -2101,23 +2135,31 @@ ada/exp_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_fixd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/eval_fat.ads ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_tss.ads \ - ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/lib.ads ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/err_vars.ads ada/errout.ads \ + ada/erroutc.ads ada/eval_fat.ads ada/exp_ch11.ads ada/exp_disp.ads \ + ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_tss.ads ada/exp_util.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/lib.ads \ + ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/widechar.ads ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2140,7 +2182,7 @@ ada/exp_imgv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2156,18 +2198,17 @@ ada/exp_intr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ ada/sem_aux.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/validsw.ads ada/widechar.ads ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2182,18 +2223,17 @@ ada/exp_pakd.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ ada/sem.ads ada/sem_aux.ads ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/validsw.ads + ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/exp_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2287,29 +2327,34 @@ ada/exp_tss.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ - ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ - ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \ - ada/fname.ads ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads \ + ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ + ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ + ada/errout.ads ada/erroutc.ads ada/eval_fat.ads ada/exp_aggr.ads \ + ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ + ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ + ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ - ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sem.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/urealp.adb ada/validsw.ads + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/exp_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2385,29 +2430,30 @@ ada/freeze.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/exp_ch7.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \ ada/freeze.ads ada/freeze.adb ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \ - ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ - ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \ + ada/interfac.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \ + ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ + ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads \ + ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ + ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ + ada/widechar.ads ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2422,20 +2468,21 @@ ada/frontend.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/osint.ads ada/output.ads ada/par.ads ada/prep.ads ada/prepcomp.ads \ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aux.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_prag.ads \ - ada/sem_scil.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb \ + ada/sem.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_elab.ads \ + ada/sem_prag.ads ada/sem_scil.ads ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/sinput-l.ads \ + ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/g-byorma.o : ada/gnat.ads ada/g-byorma.ads ada/g-byorma.adb \ ada/system.ads @@ -2473,32 +2520,33 @@ ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/back_end.ads ada/casing.ads ada/comperr.ads ada/csets.ads \ ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/einfo.adb \ ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \ - ada/erroutc.ads ada/exp_tss.ads ada/expander.ads ada/fmap.ads \ - ada/fname.ads ada/fname-uf.ads ada/frontend.ads ada/get_targ.ads \ - ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/g-table.ads \ - ada/g-table.adb ada/gnat1drv.ads ada/gnat1drv.adb ada/gnatvsn.ads \ - ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/lib.ads ada/lib.adb \ - ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-writ.ads \ - ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \ - ada/nmake.ads ada/opt.ads ada/osint.ads ada/output.ads ada/par_sco.ads \ - ada/prepcomp.ads ada/repinfo.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scos.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ - ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ - ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/sinput-l.ads ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \ - ada/s-assert.ads ada/s-bitops.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_gen.ads ada/tree_io.ads \ - ada/treepr.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/usage.ads ada/validsw.ads ada/widechar.ads + ada/erroutc.ads ada/exp_cg.ads ada/exp_tss.ads ada/expander.ads \ + ada/fmap.ads ada/fname.ads ada/fname-uf.ads ada/frontend.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/g-table.ads ada/g-table.adb ada/gnat1drv.ads ada/gnat1drv.adb \ + ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \ + ada/lib.adb ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb \ + ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads ada/output.ads \ + ada/par_sco.ads ada/prepcomp.ads ada/repinfo.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scos.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ + ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ + ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ + ada/sem_ch9.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_prag.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads \ + ada/system.ads ada/s-assert.ads ada/s-bitops.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_gen.ads \ + ada/tree_io.ads ada/treepr.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/usage.ads ada/validsw.ads \ + ada/widechar.ads ada/gnatbind.o : ada/ada.ads ada/a-comlin.ads ada/a-clrefi.ads \ ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads ada/ali.ads \ @@ -2521,15 +2569,25 @@ ada/gnatvsn.o : ada/ada.ads ada/a-unccon.ads ada/gnatvsn.ads \ ada/gnatvsn.adb ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \ ada/s-stoele.adb -ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/hlo.ads ada/hlo.adb \ - ada/hostparm.ads ada/output.ads ada/system.ads ada/s-exctab.ads \ - ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \ - ada/unchdeal.ads +ada/hlo.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/hlo.ads \ + ada/hlo.adb ada/hostparm.ads ada/output.ads ada/system.ads \ + ada/s-exctab.ads ada/s-os_lib.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-unstyp.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/hostparm.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \ ada/types.ads ada/unchconv.ads ada/unchdeal.ads +ada/i-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/interfac.ads \ + ada/i-c.ads ada/i-c.adb ada/system.ads ada/s-exctab.ads \ + ada/s-exctab.adb ada/s-htable.ads ada/s-parame.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-traent.ads + +ada/i-cstrea.o : ada/ada.ads ada/a-unccon.ads ada/interfac.ads \ + ada/i-cstrea.ads ada/i-cstrea.adb ada/system.ads ada/s-crtl.ads \ + ada/s-parame.ads + ada/impunit.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \ @@ -2615,8 +2673,8 @@ ada/layout.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch13.ads \ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ @@ -2694,15 +2752,16 @@ ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib-util.adb ada/lib-xref.ads ada/lib-xref.adb ada/namet.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/osint.ads \ ada/osint-c.ads ada/output.ads ada/restrict.ads ada/rident.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_prag.ads ada/sem_util.ads \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_prag.ads \ + ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/widechar.ads ada/lib.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads \ @@ -3130,6 +3189,18 @@ ada/scans.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads +ada/scil_ll.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ + ada/casing.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \ + ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ + ada/scil_ll.ads ada/scil_ll.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads + ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/err_vars.ads ada/errout.ads \ @@ -3207,9 +3278,9 @@ ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_aggr.adb \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ @@ -3233,27 +3304,29 @@ ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \ ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/expander.ads \ ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ ada/g-htable.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \ - ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/snames.adb ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ - ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sdefault.ads ada/sem.ads ada/sem_aggr.ads \ + ada/sem_attr.ads ada/sem_attr.adb ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/snames.adb ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ ada/validsw.ads ada/widechar.ads @@ -3301,19 +3374,18 @@ ada/sem_cat.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/output.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads \ ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3331,20 +3403,19 @@ ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch3.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch11.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3384,21 +3455,20 @@ ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch12.adb ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/sinput.adb ada/sinput-l.ads ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput-l.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/urealp.adb ada/widechar.ads ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3455,11 +3525,11 @@ ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb \ - ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads ada/sem_ch3.ads \ - ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_mech.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_case.ads \ + ada/sem_case.adb ada/sem_cat.ads ada/sem_cat.adb ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_mech.ads ada/sem_res.ads \ ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ @@ -3480,31 +3550,32 @@ ada/sem_ch4.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \ ada/debug_a.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/elists.adb ada/err_vars.ads ada/errout.ads ada/erroutc.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_disp.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/fname.ads \ - ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads \ - ada/g-htable.ads ada/hostparm.ads ada/interfac.ads ada/itypes.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/namet-sp.ads \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ + ada/eval_fat.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads ada/expander.ads \ + ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ + ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ + ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \ + ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads \ + ada/sem_aux.ads ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch4.adb \ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ - ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads \ + ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3526,20 +3597,20 @@ ada/sem_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch5.adb \ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sem_warn.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3555,11 +3626,11 @@ ada/sem_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_scil.ads \ + ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch6.adb \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads \ ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ @@ -3591,19 +3662,19 @@ ada/sem_ch7.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch3.ads \ ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch7.adb ada/sem_ch8.ads \ ada/sem_disp.ads ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ - ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ + ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3624,18 +3695,18 @@ ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads \ - ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3657,50 +3728,49 @@ ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch9.ads \ ada/sem_ch9.adb ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/sinput.adb ada/snames.ads ada/sprint.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads \ - ada/widechar.ads + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/sprint.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_disp.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \ ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \ - ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dbug.ads \ - ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads ada/exp_util.ads \ - ada/exp_util.adb ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ - ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/hostparm.ads \ - ada/inline.ads ada/interfac.ads ada/itypes.ads ada/layout.ads \ - ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ - ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch3.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_disp.adb \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ - ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/exp_cg.ads ada/exp_ch11.ads ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ + ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ + ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ + ada/rtsfind.ads ada/scans.ads ada/scil_ll.ads ada/scn.ads ada/scng.ads \ + ada/scng.adb ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_disp.adb ada/sem_eval.ads \ + ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3735,18 +3805,18 @@ ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elab.ads \ - ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ - ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ - ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_elab.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -3756,15 +3826,16 @@ ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/sem.ads ada/sem_elim.ads ada/sem_elim.adb ada/sem_prag.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_elim.ads \ + ada/sem_elim.adb ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3779,11 +3850,11 @@ ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ - ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ - ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads \ + ada/sem_ch13.ads ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads \ + ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads ada/sem_res.ads \ + ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/snames.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ @@ -3843,30 +3914,30 @@ ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ ada/namet-sp.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads \ - ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ - ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/scans.ads \ - ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_aggr.ads \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ - ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ - ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_intr.ads \ - ada/sem_mech.ads ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads \ - ada/sem_res.adb ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads \ - ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/snames.adb ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ - ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/validsw.ads \ - ada/widechar.ads + ada/nmake.adb ada/opt.ads ada/output.ads ada/par_sco.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_aggr.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ + ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch3.ads \ + ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads \ + ada/sem_prag.adb ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_vfpt.ads ada/sem_warn.ads \ + ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads ada/sinput.ads \ + ada/sinput.adb ada/snames.ads ada/snames.adb ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3889,35 +3960,34 @@ ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_eval.adb \ - ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_scil.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/urealp.adb ada/validsw.ads ada/widechar.ads + ada/sem_intr.ads ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ + ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ + ada/system.ads ada/s-carun8.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ + ada/validsw.ads ada/widechar.ads ada/sem_scil.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/einfo.adb ada/gnat.ads \ ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rtsfind.ads \ - ada/sem.ads ada/sem_aux.ads ada/sem_scil.ads ada/sem_scil.adb \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/nlists.adb ada/opt.ads ada/output.ads ada/rtsfind.ads \ + ada/scil_ll.ads ada/sem_aux.ads ada/sem_scil.ads ada/sem_scil.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/sem_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -3947,49 +4017,50 @@ ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ ada/sem_aux.ads ada/sem_ch12.ads ada/sem_ch6.ads ada/sem_ch8.ads \ ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads \ - ada/sem_util.adb ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads ada/sem_util.adb \ + ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg.adb \ + ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/casing.adb ada/checks.ads ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_ch11.ads ada/exp_disp.ads ada/exp_tss.ads ada/exp_util.ads \ - ada/fname.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/interfac.ads \ - ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-sort.adb \ - ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ - ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/exp_ch11.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \ + ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \ + ada/hostparm.ads ada/interfac.ads ada/lib.ads ada/lib.adb \ + ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \ + ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \ + ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \ + ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_scil.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/stringt.adb ada/style.ads ada/styleg.ads ada/styleg.adb \ - ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-crc32.ads \ - ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \ - ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \ - ada/widechar.ads + ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch6.ads ada/sem_ch7.ads \ + ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \ + ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/stringt.adb ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-carun8.ads \ + ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads ada/s-htable.ads \ + ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \ + ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ + ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ + ada/urealp.adb ada/widechar.ads ada/sem_vfpt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -4018,18 +4089,18 @@ ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/output.ads ada/par_sco.ads ada/rident.ads ada/rtsfind.ads \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch8.ads ada/sem_disp.ads \ - ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \ - ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/sinput.adb \ - ada/snames.ads ada/stand.ads ada/stringt.ads ada/style.ads \ - ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ - ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ - ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/sinput.adb ada/snames.ads \ + ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \ + ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-crc32.ads \ + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sinfo-cn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -4293,16 +4364,16 @@ ada/treepr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \ ada/lib.adb ada/lib-list.adb ada/lib-sort.adb ada/namet.ads \ ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/output.adb \ - ada/sem_mech.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/sinput.adb ada/snames.ads ada/stand.ads ada/stringt.ads \ - ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ - ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/tree_io.ads ada/treepr.ads \ - ada/treepr.adb ada/treeprs.ads ada/types.ads ada/uintp.ads \ - ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/scil_ll.ads ada/sem_mech.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/sinput.adb ada/snames.ads ada/stand.ads \ + ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ + ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ + ada/treepr.ads ada/treepr.adb ada/treeprs.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/treeprs.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 2740d351dbb..ee65cb2fdd1 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -309,7 +309,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \ scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o sinfo.o sinput.o \ sinput-c.o sinput-p.o snames.o stand.o stringt.o styleg.o stylesw.o system.o \ validsw.o switch.o switch-m.o table.o targparm.o tempdir.o tree_io.o types.o \ - uintp.o uname.o urealp.o usage.o widechar.o \ + uintp.o uname.o urealp.o usage.o widechar.o scil_ll.o \ $(EXTRA_GNATMAKE_OBJS) # Convert the target variable into a space separated list of architecture, @@ -407,9 +407,6 @@ ATOMICS_TARGET_PAIRS += \ a-szunau.adb<a-szunau-shared.adb \ a-szuzti.adb<a-szuzti-shared.adb -# Reset setting for now -ATOMICS_TARGET_PAIRS = - LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/')) # $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT. @@ -1451,6 +1448,7 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) EH_MECHANISM=-gcc GMEM_LIB=gmemlib + MISCLIB = -lexc THREADSLIB = -lpthread -lmach -lexc -lrt GNATLIB_SHARED = gnatlib-shared-default LIBRARY_VERSION := $(LIB_VERSION) @@ -1475,11 +1473,10 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) g-enblsp.adb<g-enblsp-vms-ia64.adb \ g-trasym.adb<g-trasym-vms-ia64.adb \ s-asthan.adb<s-asthan-vms-ia64.adb \ + s-auxdec.adb<s-auxdec-vms-ia64.adb \ s-osinte.adb<s-osinte-vms-ia64.adb \ s-osinte.ads<s-osinte-vms-ia64.ads \ s-vaflop.adb<s-vaflop-vms-ia64.adb \ - g-trasym.ads<g-trasym-unimplemented.ads \ - g-trasym.adb<g-trasym-unimplemented.adb \ system.ads<system-vms-ia64.ads LIBGNAT_TARGET_PAIRS_AUX2 = \ @@ -1490,12 +1487,12 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) LIBGNAT_TARGET_PAIRS_AUX1 = \ g-enblsp.adb<g-enblsp-vms-alpha.adb \ g-trasym.adb<g-trasym-vms-alpha.adb \ - s-auxdec.adb<s-auxdec-vms-alpha.adb \ - s-traent.adb<s-traent-vms.adb \ - s-traent.ads<s-traent-vms.ads \ s-asthan.adb<s-asthan-vms-alpha.adb \ + s-auxdec.adb<s-auxdec-vms-alpha.adb \ s-osinte.adb<s-osinte-vms.adb \ s-osinte.ads<s-osinte-vms.ads \ + s-traent.adb<s-traent-vms.adb \ + s-traent.ads<s-traent-vms.ads \ s-vaflop.adb<s-vaflop-vms-alpha.adb \ system.ads<system-vms_64.ads @@ -2113,6 +2110,7 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) ifeq ($(strip $(filter-out %86,$(arch))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-darwin.ads \ + i-forbla.adb<i-forbla-darwin.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-susv3.adb \ s-osinte.adb<s-osinte-darwin.adb \ @@ -2137,6 +2135,7 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) ifeq ($(strip $(filter-out %x86_64,$(arch))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-darwin.ads \ + i-forbla.adb<i-forbla-darwin.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-susv3.adb \ s-osinte.adb<s-osinte-darwin.adb \ @@ -2156,6 +2155,7 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) ifeq ($(strip $(filter-out powerpc%,$(arch))),) LIBGNAT_TARGET_PAIRS = \ a-intnam.ads<a-intnam-darwin.ads \ + i-forbla.adb<i-forbla-darwin.adb \ s-inmaop.adb<s-inmaop-posix.adb \ s-intman.adb<s-intman-posix.adb \ s-osinte.adb<s-osinte-darwin.adb \ @@ -2637,7 +2637,8 @@ gnatlib-shared: $(GNATLIB_SHARED) gnatlib-sjlj: - $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="" ../stamp-gnatlib1-$(RTSDIR) + $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="" \ + THREAD_KIND="$(THREAD_KIND)" ../stamp-gnatlib1-$(RTSDIR) sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := False;/' $(RTSDIR)/system.ads > $(RTSDIR)/s.ads $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads $(MAKE) $(FLAGS_TO_PASS) \ @@ -2650,7 +2651,8 @@ gnatlib-sjlj: TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib gnatlib-zcx: - $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" ../stamp-gnatlib1-$(RTSDIR) + $(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="-gcc" \ + THREAD_KIND="$(THREAD_KIND)" ../stamp-gnatlib1-$(RTSDIR) sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := True;/' $(RTSDIR)/system.ads > $(RTSDIR)/s.ads $(MV) $(RTSDIR)/s.ads $(RTSDIR)/system.ads $(MAKE) $(FLAGS_TO_PASS) \ diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index fb4769b7bb2..6952060259d 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -154,13 +154,24 @@ static tree make_type_from_size (tree, tree, bool); static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); static unsigned int ceil_alignment (unsigned HOST_WIDE_INT); static void check_ok_for_atomic (tree, Entity_Id, bool); -static int compatible_signatures_p (tree, tree); static tree create_field_decl_from (tree, tree, tree, tree, tree, tree); static tree get_rep_part (tree); static tree get_variant_part (tree); static tree create_variant_part_from (tree, tree, tree, tree, tree); static void copy_and_substitute_in_size (tree, tree, tree); static void rest_of_type_decl_compilation_no_defer (tree); + +/* The relevant constituents of a subprogram binding to a GCC builtin. Used + to pass around calls performing profile compatibilty checks. */ + +typedef struct { + Entity_Id gnat_entity; /* The Ada subprogram entity. */ + tree ada_fntype; /* The corresponding GCC type node. */ + tree btin_fntype; /* The GCC builtin function type node. */ +} intrin_binding_t; + +static bool intrin_profiles_compatible_p (intrin_binding_t *); + /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada entity, return the equivalent GCC tree for that entity (a ..._DECL node) @@ -1036,15 +1047,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = TYPE_PADDING_P (gnu_type) ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) : TYPE_FIELDS (gnu_type); - gnu_expr - = gnat_build_constructor - (gnu_type, - tree_cons - (template_field, - build_template (TREE_TYPE (template_field), - TREE_TYPE (TREE_CHAIN (template_field)), - NULL_TREE), - NULL_TREE)); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); + tree t = build_template (TREE_TYPE (template_field), + TREE_TYPE (TREE_CHAIN (template_field)), + NULL_TREE); + CONSTRUCTOR_APPEND_ELT (v, template_field, t); + gnu_expr = gnat_build_constructor (gnu_type, v); } /* Convert the expression to the type of the object except in the @@ -3901,14 +3909,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* If this subprogram is expectedly bound to a GCC builtin, fetch the - corresponding DECL node. + corresponding DECL node. Proper generation of calls later on need + proper parameter associations so we don't "break;" here. */ + if (Convention (gnat_entity) == Convention_Intrinsic + && Present (Interface_Name (gnat_entity))) + { + gnu_builtin_decl = builtin_decl_for (gnu_ext_name); - We still want the parameter associations to take place because the - proper generation of calls depends on it (a GNAT parameter without - a corresponding GCC tree has a very specific meaning), so we don't - just break here. */ - if (Convention (gnat_entity) == Convention_Intrinsic) - gnu_builtin_decl = builtin_decl_for (gnu_ext_name); + /* Unability to find the builtin decl most often indicates a + genuine mistake, but imports of unregistered intrinsics are + sometimes issued on purpose to allow hooking in alternate + bodies. We post a warning conditioned on Wshadow in this case, + to let developers be notified on demand without risking false + positives with common default sets of options. */ + + if (gnu_builtin_decl == NULL_TREE && warn_shadow) + post_error ("?gcc intrinsic not found for&!", gnat_entity); + } /* ??? What if we don't find the builtin node above ? warn ? err ? In the current state we neither warn nor err, and calls will just @@ -4204,21 +4221,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) | (TYPE_QUAL_CONST * const_flag) | (TYPE_QUAL_VOLATILE * volatile_flag)); - /* If we have a builtin decl for that function, check the signatures - compatibilities. If the signatures are compatible, use the builtin - decl. If they are not, we expect the checker predicate to have - posted the appropriate errors, and just continue with what we have - so far. */ + /* If we have a builtin decl for that function, use it. Check if the + profiles are compatible and warn if they are not. The checker is + expected to post extra diagnostics in this case. */ if (gnu_builtin_decl) { - tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl); + intrin_binding_t inb; - if (compatible_signatures_p (gnu_type, gnu_builtin_type)) - { - gnu_decl = gnu_builtin_decl; - gnu_type = gnu_builtin_type; - break; - } + inb.gnat_entity = gnat_entity; + inb.ada_fntype = gnu_type; + inb.btin_fntype = TREE_TYPE (gnu_builtin_decl); + + if (!intrin_profiles_compatible_p (&inb)) + post_error + ("?profile of& doesn''t match the builtin it binds!", + gnat_entity); + + gnu_decl = gnu_builtin_decl; + gnu_type = TREE_TYPE (gnu_builtin_decl); + break; } /* If there was no specified Interface_Name and the external and @@ -5240,6 +5261,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, gnu_param_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type)))); + /* For GCC builtins, pass Address integer types as (void *) */ + if (Convention (gnat_subprog) == Convention_Intrinsic + && Present (Interface_Name (gnat_subprog)) + && Is_Descendent_Of_Address (Etype (gnat_param))) + gnu_param_type = ptr_void_type_node; + /* VMS descriptors are themselves passed by reference. */ if (mech == By_Short_Descriptor || (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64)) @@ -8036,32 +8063,154 @@ check_ok_for_atomic (tree object, Entity_Id gnat_entity, bool comp_p) gnat_error_point, gnat_entity); } -/* Check if FTYPE1 and FTYPE2, two potentially different function type nodes, - have compatible signatures so that a call using one type may be safely - issued if the actual target function type is the other. Return 1 if it is - the case, 0 otherwise, and post errors on the incompatibilities. - This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure - that calls to the subprogram will have arguments suitable for the later - underlying builtin expansion. */ +/* Helper for the intrin compatibility checks family. Evaluate whether + two types are definitely incompatible. */ -static int -compatible_signatures_p (tree ftype1, tree ftype2) +static bool +intrin_types_incompatible_p (tree t1, tree t2) { - /* As of now, we only perform very trivial tests and consider it's the - programmer's responsibility to ensure the type correctness in the Ada - declaration, as in the regular Import cases. + enum tree_code code; + + if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)) + return false; + + if (TYPE_MODE (t1) != TYPE_MODE (t2)) + return true; + + if (TREE_CODE (t1) != TREE_CODE (t2)) + return true; + + code = TREE_CODE (t1); + + switch (code) + { + case INTEGER_TYPE: + case REAL_TYPE: + return TYPE_PRECISION (t1) != TYPE_PRECISION (t2); + + case POINTER_TYPE: + case REFERENCE_TYPE: + /* Assume designated types are ok. We'd need to account for char * and + void * variants to do better, which could rapidly get messy and isn't + clearly worth the effort. */ + return false; + + default: + break; + } + + return false; +} + +/* Helper for intrin_profiles_compatible_p, to perform compatibility checks + on the Ada/builtin argument lists for the INB binding. */ + +static bool +intrin_arglists_compatible_p (intrin_binding_t * inb) +{ + tree ada_args = TYPE_ARG_TYPES (inb->ada_fntype); + tree btin_args = TYPE_ARG_TYPES (inb->btin_fntype); + + /* Sequence position of the last argument we checked. */ + int argpos = 0; + + while (ada_args != 0 || btin_args != 0) + { + tree ada_type, btin_type; + + /* If one list is shorter than the other, they fail to match. */ + if (ada_args == 0 || btin_args == 0) + return false; + + ada_type = TREE_VALUE (ada_args); + btin_type = TREE_VALUE (btin_args); + + /* If we're done with the Ada args and not with the internal builtin + args, or the other way around, complain. */ + if (ada_type == void_type_node + && btin_type != void_type_node) + { + post_error ("?Ada arguments list too short!", inb->gnat_entity); + return false; + } + + if (btin_type == void_type_node + && ada_type != void_type_node) + { + post_error_ne_num ("?Ada arguments list too long ('> ^)!", + inb->gnat_entity, inb->gnat_entity, argpos); + return false; + } + + /* Otherwise, check that types match for the current argument. */ + argpos ++; + if (intrin_types_incompatible_p (ada_type, btin_type)) + { + post_error_ne_num ("?intrinsic binding type mismatch on argument ^!", + inb->gnat_entity, inb->gnat_entity, argpos); + return false; + } + + ada_args = TREE_CHAIN (ada_args); + btin_args = TREE_CHAIN (btin_args); + } + + return true; +} + +/* Helper for intrin_profiles_compatible_p, to perform compatibility checks + on the Ada/builtin return values for the INB binding. */ + +static bool +intrin_return_compatible_p (intrin_binding_t * inb) +{ + tree ada_return_type = TREE_TYPE (inb->ada_fntype); + tree btin_return_type = TREE_TYPE (inb->btin_fntype); + + /* Accept function imported as procedure, common and convenient. */ + if (VOID_TYPE_P (ada_return_type) + && !VOID_TYPE_P (btin_return_type)) + return true; + + /* Check return types compatibility otherwise. Note that this + handles void/void as well. */ + if (intrin_types_incompatible_p (btin_return_type, ada_return_type)) + { + post_error ("?intrinsic binding type mismatch on return value!", + inb->gnat_entity); + return false; + } + + return true; +} + +/* Check and return whether the Ada and gcc builtin profiles bound by INB are + compatible. Issue relevant warnings when they are not. + + This is intended as a light check to diagnose the most obvious cases, not + as a full fledged type compatiblity predicate. It is the programmer's + responsibility to ensure correctness of the Ada declarations in Imports, + especially when binding straight to a compiler internal. */ + +static bool +intrin_profiles_compatible_p (intrin_binding_t * inb) +{ + /* Check compatibility on return values and argument lists, each responsible + for posting warnings as appropriate. Ensure use of the proper sloc for + this purpose. */ + + bool arglists_compatible_p, return_compatible_p; + location_t saved_location = input_location; + + Sloc_to_locus (Sloc (inb->gnat_entity), &input_location); - Mismatches typically result in either error messages from the builtin - expander, internal compiler errors, or in a real call sequence. This - should be refined to issue diagnostics helping error detection and - correction. */ + return_compatible_p = intrin_return_compatible_p (inb); + arglists_compatible_p = intrin_arglists_compatible_p (inb); - /* Almost fake test, ensuring a use of each argument. */ - if (ftype1 == ftype2) - return 1; + input_location = saved_location; - return 1; + return return_compatible_p && arglists_compatible_p; } /* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h index 74a94d73261..767700f6f76 100644 --- a/gcc/ada/gcc-interface/gigi.h +++ b/gcc/ada/gcc-interface/gigi.h @@ -785,9 +785,9 @@ extern tree build_call_0_expr (tree fundecl); (N_Raise_{Constraint,Storage,Program}_Error). */ extern tree build_call_raise (int msg, Node_Id gnat_node, char kind); -/* Return a CONSTRUCTOR of TYPE whose list is LIST. This is not the +/* Return a CONSTRUCTOR of TYPE whose elements are V. This is not the same as build_constructor in the language-independent tree.c. */ -extern tree gnat_build_constructor (tree type, tree list); +extern tree gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v); /* Return a COMPONENT_REF to access a field that is given by COMPONENT, an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index 229663b7ce2..4033173d782 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -25,7 +25,7 @@ /* This file contains parts of the compiler that are required for interfacing with GCC but otherwise do nothing and parts of Gigi that need to know - about RTL. */ + about GIMPLE. */ #include "config.h" #include "system.h" @@ -44,7 +44,6 @@ #include "options.h" #include "plugin.h" #include "function.h" /* For pass_by_reference. */ -#include "except.h" /* For USING_SJLJ_EXCEPTIONS. */ #include "ada.h" #include "adadecode.h" @@ -135,6 +134,9 @@ static tree gnat_eh_personality (void); struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; +/* This symbol needs to be defined for the front-end. */ +void *callgraph_info_file = NULL; + /* How much we want of our DWARF extensions. Some of our dwarf+ extensions are incompatible with regular GDB versions, so we must make sure to only produce them on explicit request. This is eventually reflected into the diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 7a94393b0e0..c62e7e632c8 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -33,6 +33,7 @@ #include "output.h" #include "libfuncs.h" /* For set_stack_check_libfunc. */ #include "tree-iterator.h" +#include "tree-flow.h" #include "gimple.h" #include "ada.h" @@ -153,35 +154,25 @@ struct GTY((chain_next ("%h.next"))) elab_info { static GTY(()) struct elab_info *elab_info_list; -/* Free list of TREE_LIST nodes used for stacks. */ -static GTY((deletable)) tree gnu_stack_free_list; +/* Stack of exception pointer variables. Each entry is the VAR_DECL + that stores the address of the raised exception. Nonzero means we + are in an exception handler. Not used in the zero-cost case. */ +static GTY(()) VEC(tree,gc) *gnu_except_ptr_stack; -/* List of TREE_LIST nodes representing a stack of exception pointer - variables. TREE_VALUE is the VAR_DECL that stores the address of - the raised exception. Nonzero means we are in an exception - handler. Not used in the zero-cost case. */ -static GTY(()) tree gnu_except_ptr_stack; +/* Stack for storing the current elaboration procedure decl. */ +static GTY(()) VEC(tree,gc) *gnu_elab_proc_stack; -/* List of TREE_LIST nodes used to store the current elaboration procedure - decl. TREE_VALUE is the decl. */ -static GTY(()) tree gnu_elab_proc_stack; +/* Stack of labels to be used as a goto target instead of a return in + some functions. See processing for N_Subprogram_Body. */ +static GTY(()) VEC(tree,gc) *gnu_return_label_stack; -/* Variable that stores a list of labels to be used as a goto target instead of - a return in some functions. See processing for N_Subprogram_Body. */ -static GTY(()) tree gnu_return_label_stack; +/* Stack of LOOP_STMT nodes. */ +static GTY(()) VEC(tree,gc) *gnu_loop_label_stack; -/* List of TREE_LIST nodes representing a stack of LOOP_STMT nodes. - TREE_VALUE of each entry is the label of the corresponding LOOP_STMT. */ -static GTY(()) tree gnu_loop_label_stack; - -/* List of TREE_LIST nodes representing labels for switch statements. - TREE_VALUE of each entry is the label at the end of the switch. */ -static GTY(()) tree gnu_switch_label_stack; - -/* List of TREE_LIST nodes containing the stacks for N_{Push,Pop}_*_Label. */ -static GTY(()) tree gnu_constraint_error_label_stack; -static GTY(()) tree gnu_storage_error_label_stack; -static GTY(()) tree gnu_program_error_label_stack; +/* The stacks for N_{Push,Pop}_*_Label. */ +static GTY(()) VEC(tree,gc) *gnu_constraint_error_label_stack; +static GTY(()) VEC(tree,gc) *gnu_storage_error_label_stack; +static GTY(()) VEC(tree,gc) *gnu_program_error_label_stack; /* Map GNAT tree codes to GCC tree codes for simple expressions. */ static enum tree_code gnu_codes[Number_Node_Kinds]; @@ -192,10 +183,8 @@ static void record_code_position (Node_Id); static void insert_code_for (Node_Id); static void add_cleanup (tree, Node_Id); static void add_stmt_list (List_Id); -static void push_exception_label_stack (tree *, Entity_Id); +static void push_exception_label_stack (VEC(tree,gc) **, Entity_Id); static tree build_stmt_group (List_Id, bool); -static void push_stack (tree *, tree, tree); -static void pop_stack (tree *); static enum gimplify_status gnat_gimplify_stmt (tree *); static void elaborate_all_entities (Node_Id); static void process_freeze_entity (Node_Id); @@ -213,6 +202,7 @@ static tree extract_values (tree, tree); static tree pos_to_constructor (Node_Id, tree, Entity_Id); static tree maybe_implicit_deref (tree); static void set_expr_location_from_node (tree, Node_Id); +static void set_gnu_expr_location_from_node (tree, Node_Id); static int lvalue_required_p (Node_Id, tree, bool, bool, bool); /* Hooks for debug info back-ends, only supported and used in a restricted set @@ -555,10 +545,16 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, if (TARGET_VTABLE_USES_DESCRIPTORS) { tree null_node = fold_convert (ptr_void_ftype, null_pointer_node); - tree field_list = NULL_TREE, null_list = NULL_TREE; + tree field_list = NULL_TREE; int j; + VEC(constructor_elt,gc) *null_vec = NULL; + constructor_elt *elt; fdesc_type_node = make_node (RECORD_TYPE); + VEC_safe_grow (constructor_elt, gc, null_vec, + TARGET_VTABLE_USES_DESCRIPTORS); + elt = (VEC_address (constructor_elt,null_vec) + + TARGET_VTABLE_USES_DESCRIPTORS - 1); for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++) { @@ -567,12 +563,14 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, NULL_TREE, NULL_TREE, 0, 1); TREE_CHAIN (field) = field_list; field_list = field; - null_list = tree_cons (field, null_node, null_list); + elt->index = field; + elt->value = null_node; + elt--; } finish_record_type (fdesc_type_node, nreverse (field_list), 0, false); record_builtin_type ("descriptor", fdesc_type_node); - null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list); + null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec); } long_long_float_type @@ -609,11 +607,10 @@ gigi (Node_Id gnat_root, int max_gnat_node, int number_name ATTRIBUTE_UNUSED, user available facilities for Intrinsic imports. */ gnat_install_builtins (); - gnu_except_ptr_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_constraint_error_label_stack - = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_storage_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); - gnu_program_error_label_stack = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE); + VEC_safe_push (tree, gc, gnu_except_ptr_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_constraint_error_label_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_storage_error_label_stack, NULL_TREE); + VEC_safe_push (tree, gc, gnu_program_error_label_stack, NULL_TREE); /* Process any Pragma Ident for the main unit. */ #ifdef ASM_OUTPUT_IDENT @@ -973,7 +970,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) variables of non-constant size because they are automatically allocated to memory. There might be no way of allocating a proper temporary for them in any case. We only do this for SJLJ though. */ - if (TREE_VALUE (gnu_except_ptr_stack) + if (VEC_last (tree, gnu_except_ptr_stack) && TREE_CODE (gnu_result) == VAR_DECL && TREE_CODE (DECL_SIZE_UNIT (gnu_result)) == INTEGER_CST) TREE_THIS_VOLATILE (gnu_result) = TREE_SIDE_EFFECTS (gnu_result) = 1; @@ -1242,10 +1239,12 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) else if (TARGET_VTABLE_USES_DESCRIPTORS && Is_Dispatch_Table_Entity (Etype (gnat_node))) { - tree gnu_field, gnu_list = NULL_TREE, t; + tree gnu_field, t; /* Descriptors can only be built here for top-level functions. */ bool build_descriptor = (global_bindings_p () != 0); int i; + VEC(constructor_elt,gc) *gnu_vec = NULL; + constructor_elt *elt; gnu_result_type = get_unpadded_type (Etype (gnat_node)); @@ -1260,6 +1259,10 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result); } + VEC_safe_grow (constructor_elt, gc, gnu_vec, + TARGET_VTABLE_USES_DESCRIPTORS); + elt = (VEC_address (constructor_elt, gnu_vec) + + TARGET_VTABLE_USES_DESCRIPTORS - 1); for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0; i < TARGET_VTABLE_USES_DESCRIPTORS; gnu_field = TREE_CHAIN (gnu_field), i++) @@ -1274,10 +1277,12 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result, gnu_field, NULL_TREE); - gnu_list = tree_cons (gnu_field, t, gnu_list); + elt->index = gnu_field; + elt->value = t; + elt--; } - gnu_result = gnat_build_constructor (gnu_result_type, gnu_list); + gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); break; } @@ -1917,9 +1922,9 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) static tree Case_Statement_to_gnu (Node_Id gnat_node) { - tree gnu_result; - tree gnu_expr; + tree gnu_result, gnu_expr, gnu_label; Node_Id gnat_when; + bool may_fallthru = false; gnu_expr = gnat_to_gnu (Expression (gnat_node)); gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); @@ -1942,10 +1947,9 @@ Case_Statement_to_gnu (Node_Id gnat_node) /* We build a SWITCH_EXPR that contains the code with interspersed CASE_LABEL_EXPRs for each label. */ - - push_stack (&gnu_switch_label_stack, NULL_TREE, - create_artificial_label (input_location)); + gnu_label = create_artificial_label (input_location); start_stmt_group (); + for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); Present (gnat_when); gnat_when = Next_Non_Pragma (gnat_when)) @@ -2023,18 +2027,22 @@ Case_Statement_to_gnu (Node_Id gnat_node) containing the Case statement. */ if (choices_added_p) { - add_stmt (build_stmt_group (Statements (gnat_when), true)); - add_stmt (build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); + tree group = build_stmt_group (Statements (gnat_when), true); + bool group_may_fallthru = block_may_fallthru (group); + add_stmt (group); + if (group_may_fallthru) + { + add_stmt (build1 (GOTO_EXPR, void_type_node, gnu_label)); + may_fallthru = true; + } } } - /* Now emit a definition of the label all the cases branched to. */ - add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_switch_label_stack))); + /* Now emit a definition of the label the cases branch to, if any. */ + if (may_fallthru) + add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label)); gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, end_stmt_group (), NULL_TREE); - pop_stack (&gnu_switch_label_stack); return gnu_result; } @@ -2100,7 +2108,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node) /* Save the end label of this LOOP_STMT in a stack so that a corresponding N_Exit_Statement can find it. */ - push_stack (&gnu_loop_label_stack, NULL_TREE, gnu_loop_label); + VEC_safe_push (tree, gc, gnu_loop_label_stack, gnu_loop_label); /* Set the condition under which the loop must keep going. For the case "LOOP .... END LOOP;" the condition is always true. */ @@ -2317,7 +2325,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node) else gnu_result = gnu_loop_stmt; - pop_stack (&gnu_loop_label_stack); + VEC_pop (tree, gnu_loop_label_stack); return gnu_result; } @@ -2450,9 +2458,10 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) properly copies them out. We do this by making a new block and converting any inner return into a goto to a label at the end of the block. */ gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); - push_stack (&gnu_return_label_stack, NULL_TREE, - gnu_cico_list ? create_artificial_label (input_location) - : NULL_TREE); + VEC_safe_push (tree, gc, gnu_return_label_stack, + gnu_cico_list + ? create_artificial_label (input_location) + : NULL_TREE); /* Get a tree corresponding to the code for the subprogram. */ start_stmt_group (); @@ -2470,9 +2479,8 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) { /* Skip any entries that have been already filled in; they must correspond to In Out parameters. */ - for (; gnu_cico_list && TREE_VALUE (gnu_cico_list); - gnu_cico_list = TREE_CHAIN (gnu_cico_list)) - ; + while (gnu_cico_list && TREE_VALUE (gnu_cico_list)) + gnu_cico_list = TREE_CHAIN (gnu_cico_list); /* Do any needed references for padded types. */ TREE_VALUE (gnu_cico_list) @@ -2540,7 +2548,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) We need to make a block that contains the definition of that label and the copying of the return value. It first contains the function, then the label and copy statement. */ - if (TREE_VALUE (gnu_return_label_stack)) + if (VEC_last (tree, gnu_return_label_stack)) { tree gnu_retval; @@ -2548,14 +2556,14 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_pushlevel (); add_stmt (gnu_result); add_stmt (build1 (LABEL_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack))); + VEC_last (tree, gnu_return_label_stack))); gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); if (list_length (gnu_cico_list) == 1) gnu_retval = TREE_VALUE (gnu_cico_list); else - gnu_retval = gnat_build_constructor (TREE_TYPE (gnu_subprog_type), - gnu_cico_list); + gnu_retval = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), + gnu_cico_list); add_stmt_with_node (build_return_expr (gnu_result_decl, gnu_retval), End_Label (Handled_Statement_Sequence (gnat_node))); @@ -2563,7 +2571,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnu_result = end_stmt_group (); } - pop_stack (&gnu_return_label_stack); + VEC_pop (tree, gnu_return_label_stack); /* Set the end location. */ Sloc_to_locus @@ -2666,7 +2674,7 @@ call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target) so we can give them the scope of the elaboration routine at top level. */ else if (!current_function_decl) { - current_function_decl = TREE_VALUE (gnu_elab_proc_stack); + current_function_decl = VEC_last (tree, gnu_elab_proc_stack); went_into_elab_proc = true; } @@ -3260,12 +3268,13 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) start_stmt_group (); gnat_pushlevel (); - push_stack (&gnu_except_ptr_stack, NULL_TREE, - create_var_decl (get_identifier ("EXCEPT_PTR"), - NULL_TREE, - build_pointer_type (except_type_node), - build_call_0_expr (get_excptr_decl), false, - false, false, false, NULL, gnat_node)); + VEC_safe_push (tree, gc, gnu_except_ptr_stack, + create_var_decl (get_identifier ("EXCEPT_PTR"), + NULL_TREE, + build_pointer_type (except_type_node), + build_call_0_expr (get_excptr_decl), + false, + false, false, false, NULL, gnat_node)); /* Generate code for each handler. The N_Exception_Handler case does the real work and returns a COND_EXPR for each handler, which we chain @@ -3289,7 +3298,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) /* If none of the exception handlers did anything, re-raise but do not defer abortion. */ gnu_expr = build_call_1_expr (raise_nodefer_decl, - TREE_VALUE (gnu_except_ptr_stack)); + VEC_last (tree, gnu_except_ptr_stack)); set_expr_location_from_node (gnu_expr, Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node); @@ -3301,7 +3310,7 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) /* End the binding level dedicated to the exception handlers and get the whole statement group. */ - pop_stack (&gnu_except_ptr_stack); + VEC_pop (tree, gnu_except_ptr_stack); gnat_poplevel (); gnu_handler = end_stmt_group (); @@ -3385,7 +3394,7 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) build_component_ref (build_unary_op (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), + VEC_last (tree, gnu_except_ptr_stack)), get_identifier ("not_handled_by_others"), NULL_TREE, false)), integer_zero_node); @@ -3406,8 +3415,9 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) this_choice = build_binary_op - (EQ_EXPR, boolean_type_node, TREE_VALUE (gnu_except_ptr_stack), - convert (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)), + (EQ_EXPR, boolean_type_node, + VEC_last (tree, gnu_except_ptr_stack), + convert (TREE_TYPE (VEC_last (tree, gnu_except_ptr_stack)), build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); /* If this is the distinguished exception "Non_Ada_Error" (and we are @@ -3418,7 +3428,7 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) tree gnu_comp = build_component_ref (build_unary_op (INDIRECT_REF, NULL_TREE, - TREE_VALUE (gnu_except_ptr_stack)), + VEC_last (tree, gnu_except_ptr_stack)), get_identifier ("lang"), NULL_TREE, false); this_choice @@ -3555,7 +3565,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) NULL_TREE, void_ftype, NULL_TREE, false, true, false, NULL, gnat_unit); struct elab_info *info; - push_stack (&gnu_elab_proc_stack, NULL_TREE, gnu_elab_proc_decl); + VEC_safe_push (tree, gc, gnu_elab_proc_stack, gnu_elab_proc_decl); DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1; /* Initialize the information structure for the function. */ @@ -3642,7 +3652,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) /* Generate elaboration code for this unit, if necessary, and say whether we did or not. */ - pop_stack (&gnu_elab_proc_stack); + VEC_pop (tree, gnu_elab_proc_stack); /* Invalidate the global renaming pointers. This is necessary because stabilization of the renamed entities may create SAVE_EXPRs which @@ -3744,7 +3754,7 @@ gnat_to_gnu (Node_Id gnat_node) the elaboration procedure, so mark us as being in that procedure. */ if (!current_function_decl) { - current_function_decl = TREE_VALUE (gnu_elab_proc_stack); + current_function_decl = VEC_last (tree, gnu_elab_proc_stack); went_into_elab_proc = true; } @@ -3755,7 +3765,7 @@ gnat_to_gnu (Node_Id gnat_node) every nested real statement instead. This also avoids triggering spurious errors on dummy (empty) sequences created by the front-end for package bodies in some cases. */ - if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack) + if (current_function_decl == VEC_last (tree, gnu_elab_proc_stack) && kind != N_Handled_Sequence_Of_Statements) Check_Elaboration_Code_Allowed (gnat_node); } @@ -3918,24 +3928,21 @@ gnat_to_gnu (Node_Id gnat_node) String_Id gnat_string = Strval (gnat_node); int length = String_Length (gnat_string); int i; - tree gnu_list = NULL_TREE; tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); + VEC(constructor_elt,gc) *gnu_vec + = VEC_alloc (constructor_elt, gc, length); for (i = 0; i < length; i++) { - gnu_list - = tree_cons (gnu_idx, - build_int_cst (TREE_TYPE (gnu_result_type), - Get_String_Char (gnat_string, - i + 1)), - gnu_list); + tree t = build_int_cst (TREE_TYPE (gnu_result_type), + Get_String_Char (gnat_string, i + 1)); + CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t); gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, integer_one_node, 0); } - gnu_result - = gnat_build_constructor (gnu_result_type, nreverse (gnu_list)); + gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); } break; @@ -4323,7 +4330,7 @@ gnat_to_gnu (Node_Id gnat_node) gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type); if (Null_Record_Present (gnat_node)) - gnu_result = gnat_build_constructor (gnu_aggr_type, NULL_TREE); + gnu_result = gnat_build_constructor (gnu_aggr_type, NULL); else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE || TREE_CODE (gnu_aggr_type) == UNION_TYPE) @@ -4879,7 +4886,7 @@ gnat_to_gnu (Node_Id gnat_node) ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), (Present (Name (gnat_node)) ? get_gnu_tree (Entity (Name (gnat_node))) - : TREE_VALUE (gnu_loop_label_stack))); + : VEC_last (tree, gnu_loop_label_stack))); break; case N_Return_Statement: @@ -4888,13 +4895,13 @@ gnat_to_gnu (Node_Id gnat_node) /* If we have a return label defined, convert this into a branch to that label. The return proper will be handled elsewhere. */ - if (TREE_VALUE (gnu_return_label_stack)) + if (VEC_last (tree, gnu_return_label_stack)) { gnu_result = build1 (GOTO_EXPR, void_type_node, - TREE_VALUE (gnu_return_label_stack)); + VEC_last (tree, gnu_return_label_stack)); /* When not optimizing, make sure the return is preserved. */ if (!optimize && Comes_From_Source (gnat_node)) - DECL_ARTIFICIAL (TREE_VALUE (gnu_return_label_stack)) = 0; + DECL_ARTIFICIAL (VEC_last (tree, gnu_return_label_stack)) = 0; break; } @@ -5154,18 +5161,15 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Pop_Constraint_Error_Label: - gnu_constraint_error_label_stack - = TREE_CHAIN (gnu_constraint_error_label_stack); + VEC_pop (tree, gnu_constraint_error_label_stack); break; case N_Pop_Storage_Error_Label: - gnu_storage_error_label_stack - = TREE_CHAIN (gnu_storage_error_label_stack); + VEC_pop (tree, gnu_storage_error_label_stack); break; case N_Pop_Program_Error_Label: - gnu_program_error_label_stack - = TREE_CHAIN (gnu_program_error_label_stack); + VEC_pop (tree, gnu_program_error_label_stack); break; /******************************/ @@ -5327,6 +5331,19 @@ gnat_to_gnu (Node_Id gnat_node) /* Added Nodes */ /****************/ + case N_Expression_With_Actions: + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + /* This construct doesn't define a scope so we don't wrap the statement + list in a BIND_EXPR; however, we wrap it in a SAVE_EXPR to protect it + from unsharing. */ + gnu_result = build_stmt_group (Actions (gnat_node), false); + gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result); + TREE_SIDE_EFFECTS (gnu_result) = 1; + gnu_expr = gnat_to_gnu (Expression (gnat_node)); + gnu_result + = build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_result, gnu_expr); + break; + case N_Freeze_Entity: start_stmt_group (); process_freeze_entity (gnat_node); @@ -5546,17 +5563,11 @@ gnat_to_gnu (Node_Id gnat_node) convert (gnu_result_type, boolean_false_node)); - /* Set the location information on the result if it is a real expression. - References can be reused for multiple GNAT nodes and they would get - the location information of their last use. Note that we may have + /* Set the location information on the result. Note that we may have no result if we tried to build a CALL_EXPR node to a procedure with no side-effects and optimization is enabled. */ - if (gnu_result - && EXPR_P (gnu_result) - && TREE_CODE (gnu_result) != NOP_EXPR - && !REFERENCE_CLASS_P (gnu_result) - && !EXPR_HAS_LOCATION (gnu_result)) - set_expr_location_from_node (gnu_result, gnat_node); + if (gnu_result && EXPR_P (gnu_result)) + set_gnu_expr_location_from_node (gnu_result, gnat_node); /* If we're supposed to return something of void_type, it means we have something we're elaborating for effect, so just return. */ @@ -5682,13 +5693,13 @@ gnat_to_gnu (Node_Id gnat_node) label to push onto the stack. */ static void -push_exception_label_stack (tree *gnu_stack, Entity_Id gnat_label) +push_exception_label_stack (VEC(tree,gc) **gnu_stack, Entity_Id gnat_label) { tree gnu_label = (Present (gnat_label) ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0) : NULL_TREE); - *gnu_stack = tree_cons (NULL_TREE, gnu_label, *gnu_stack); + VEC_safe_push (tree, gc, *gnu_stack, gnu_label); } /* Record the current code position in GNAT_NODE. */ @@ -5938,37 +5949,6 @@ build_stmt_group (List_Id gnat_list, bool binding_p) return end_stmt_group (); } -/* Push and pop routines for stacks. We keep a free list around so we - don't waste tree nodes. */ - -static void -push_stack (tree *gnu_stack_ptr, tree gnu_purpose, tree gnu_value) -{ - tree gnu_node = gnu_stack_free_list; - - if (gnu_node) - { - gnu_stack_free_list = TREE_CHAIN (gnu_node); - TREE_CHAIN (gnu_node) = *gnu_stack_ptr; - TREE_PURPOSE (gnu_node) = gnu_purpose; - TREE_VALUE (gnu_node) = gnu_value; - } - else - gnu_node = tree_cons (gnu_purpose, gnu_value, *gnu_stack_ptr); - - *gnu_stack_ptr = gnu_node; -} - -static void -pop_stack (tree *gnu_stack_ptr) -{ - tree gnu_node = *gnu_stack_ptr; - - *gnu_stack_ptr = TREE_CHAIN (gnu_node); - TREE_CHAIN (gnu_node) = gnu_stack_free_list; - gnu_stack_free_list = gnu_node; -} - /* Generate GIMPLE in place for the expression at *EXPR_P. */ int @@ -7340,9 +7320,9 @@ static tree pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, Entity_Id gnat_component_type) { - tree gnu_expr_list = NULL_TREE; tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type)); tree gnu_expr; + VEC(constructor_elt,gc) *gnu_expr_vec = NULL; for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr)) { @@ -7365,14 +7345,13 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty); } - gnu_expr_list - = tree_cons (gnu_index, convert (TREE_TYPE (gnu_array_type), gnu_expr), - gnu_expr_list); + CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index, + convert (TREE_TYPE (gnu_array_type), gnu_expr)); gnu_index = int_const_binop (PLUS_EXPR, gnu_index, integer_one_node, 0); } - return gnat_build_constructor (gnu_array_type, nreverse (gnu_expr_list)); + return gnat_build_constructor (gnu_array_type, gnu_expr_vec); } /* Subroutine of assoc_to_constructor: VALUES is a list of field associations, @@ -7383,8 +7362,8 @@ pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, static tree extract_values (tree values, tree record_type) { - tree result = NULL_TREE; tree field, tem; + VEC(constructor_elt,gc) *v = NULL; for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) { @@ -7418,10 +7397,10 @@ extract_values (tree values, tree record_type) if (!value) continue; - result = tree_cons (field, value, result); + CONSTRUCTOR_APPEND_ELT (v, field, value); } - return gnat_build_constructor (record_type, nreverse (result)); + return gnat_build_constructor (record_type, v); } /* EXP is to be treated as an array or record. Handle the cases when it is @@ -7491,6 +7470,37 @@ set_expr_location_from_node (tree node, Node_Id gnat_node) SET_EXPR_LOCATION (node, locus); } + +/* More elaborate version of set_expr_location_from_node to be used in more + general contexts, for example the result of the translation of a generic + GNAT node. */ + +static void +set_gnu_expr_location_from_node (tree node, Node_Id gnat_node) +{ + /* Set the location information on the node if it is a real expression. + References can be reused for multiple GNAT nodes and they would get + the location information of their last use. Also make sure not to + overwrite an existing location as it is probably more precise. */ + + switch (TREE_CODE (node)) + { + CASE_CONVERT: + case NON_LVALUE_EXPR: + break; + + case COMPOUND_EXPR: + if (EXPR_P (TREE_OPERAND (node, 1))) + set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node); + + /* ... fall through ... */ + + default: + if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node)) + set_expr_location_from_node (node, gnat_node); + break; + } +} /* Return a colon-separated list of encodings contained in encoded Ada name. */ @@ -7641,11 +7651,11 @@ tree get_exception_label (char kind) { if (kind == N_Raise_Constraint_Error) - return TREE_VALUE (gnu_constraint_error_label_stack); + return VEC_last (tree, gnu_constraint_error_label_stack); else if (kind == N_Raise_Storage_Error) - return TREE_VALUE (gnu_storage_error_label_stack); + return VEC_last (tree, gnu_storage_error_label_stack); else if (kind == N_Raise_Program_Error) - return TREE_VALUE (gnu_program_error_label_stack); + return VEC_last (tree, gnu_program_error_label_stack); else return NULL_TREE; } diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 0416db3b875..c5d612da91b 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -2222,7 +2222,7 @@ max_size (tree exp, bool max_p) tree build_template (tree template_type, tree array_type, tree expr) { - tree template_elts = NULL_TREE; + VEC(constructor_elt,gc) *template_elts = NULL; tree bound_list = NULL_TREE; tree field; @@ -2271,11 +2271,11 @@ build_template (tree template_type, tree array_type, tree expr) min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr); max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr); - template_elts = tree_cons (TREE_CHAIN (field), max, - tree_cons (field, min, template_elts)); + CONSTRUCTOR_APPEND_ELT (template_elts, field, min); + CONSTRUCTOR_APPEND_ELT (template_elts, TREE_CHAIN (field), max); } - return gnat_build_constructor (template_type, nreverse (template_elts)); + return gnat_build_constructor (template_type, template_elts); } /* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a @@ -2950,6 +2950,7 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) /* See the head comment of build_vms_descriptor. */ int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); tree lfield, ufield; + VEC(constructor_elt,gc) *v; /* Convert POINTER to the pointer-to-array type. */ gnu_expr64 = convert (p_array_type, gnu_expr64); @@ -2959,14 +2960,15 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) case 1: /* Class S */ case 15: /* Class SB */ /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */ + v = VEC_alloc (constructor_elt, gc, 2); t = TREE_CHAIN (TREE_CHAIN (klass)); t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - t = tree_cons (min_field, - convert (TREE_TYPE (min_field), integer_one_node), - tree_cons (max_field, - convert (TREE_TYPE (max_field), t), - NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + CONSTRUCTOR_APPEND_ELT (v, min_field, + convert (TREE_TYPE (min_field), + integer_one_node)); + CONSTRUCTOR_APPEND_ELT (v, max_field, + convert (TREE_TYPE (max_field), t)); + template_tree = gnat_build_constructor (template_type, v); template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); /* For class S, we are done. */ @@ -2990,10 +2992,11 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); /* Build the template in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (template_type), lfield, - tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), - ufield, NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield); + template_tree = gnat_build_constructor (template_type, v); /* Otherwise use the {1, LENGTH} template we build above. */ template_addr = build3 (COND_EXPR, p_bounds_type, u, @@ -3037,10 +3040,11 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield); /* Build the template in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (template_type), lfield, - tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)), - ufield, NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (template_type)), + ufield); + template_tree = gnat_build_constructor (template_type, v); template_tree = build3 (COND_EXPR, template_type, u, build_call_raise (CE_Length_Check_Failed, Empty, N_Raise_Constraint_Error), @@ -3057,10 +3061,11 @@ convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) } /* Build the fat pointer in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr64, - tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), - template_addr, NULL_TREE)); - return gnat_build_constructor (gnu_type, t); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr64); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr); + return gnat_build_constructor (gnu_type, v); } else @@ -3098,6 +3103,7 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) tree template_tree, template_addr, aflags, dimct, t, u; /* See the head comment of build_vms_descriptor. */ int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); + VEC(constructor_elt,gc) *v; /* Convert POINTER to the pointer-to-array type. */ gnu_expr32 = convert (p_array_type, gnu_expr32); @@ -3107,14 +3113,15 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) case 1: /* Class S */ case 15: /* Class SB */ /* Build {1, LENGTH} template; LENGTH is the 1st field. */ + v = VEC_alloc (constructor_elt, gc, 2); t = TYPE_FIELDS (desc_type); t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - t = tree_cons (min_field, - convert (TREE_TYPE (min_field), integer_one_node), - tree_cons (max_field, - convert (TREE_TYPE (max_field), t), - NULL_TREE)); - template_tree = gnat_build_constructor (template_type, t); + CONSTRUCTOR_APPEND_ELT (v, min_field, + convert (TREE_TYPE (min_field), + integer_one_node)); + CONSTRUCTOR_APPEND_ELT (v, max_field, + convert (TREE_TYPE (max_field), t)); + template_tree = gnat_build_constructor (template_type, v); template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); /* For class S, we are done. */ @@ -3178,11 +3185,12 @@ convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) } /* Build the fat pointer in the form of a constructor. */ - t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr32, - tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)), - template_addr, NULL_TREE)); + v = VEC_alloc (constructor_elt, gc, 2); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr32); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (gnu_type)), + template_addr); - return gnat_build_constructor (gnu_type, t); + return gnat_build_constructor (gnu_type, v); } else @@ -3551,19 +3559,19 @@ convert_to_fat_pointer (tree type, tree expr) tree p_array_type = TREE_TYPE (TYPE_FIELDS (type)); tree etype = TREE_TYPE (expr); tree template_tree; + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); /* If EXPR is null, make a fat pointer that contains null pointers to the template and array. */ if (integer_zerop (expr)) - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - convert (p_array_type, expr), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - convert (build_pointer_type (template_type), - expr), - NULL_TREE))); + { + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (p_array_type, expr)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (type)), + convert (build_pointer_type (template_type), + expr)); + return gnat_build_constructor (type, v); + } /* If EXPR is a thin pointer, make template and data from the record.. */ else if (TYPE_IS_THIN_POINTER_P (etype)) @@ -3598,15 +3606,12 @@ convert_to_fat_pointer (tree type, tree expr) Note that the call to "build_template" above is still fine because it will only refer to the provided TEMPLATE_TYPE in this case. */ - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - convert (p_array_type, expr), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - build_unary_op (ADDR_EXPR, NULL_TREE, - template_tree), - NULL_TREE))); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (p_array_type, expr)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (type)), + build_unary_op (ADDR_EXPR, NULL_TREE, + template_tree)); + return gnat_build_constructor (type, v); } /* Convert to a thin pointer type, TYPE. The only thing we know how to convert @@ -3663,6 +3668,8 @@ convert (tree type, tree expr) constructor to build the record, unless a variable size is involved. */ else if (code == RECORD_TYPE && TYPE_PADDING_P (type)) { + VEC(constructor_elt,gc) *v; + /* If we previously converted from another type and our type is of variable size, remove the conversion to avoid the need for variable-sized temporaries. Likewise for a conversion between @@ -3713,13 +3720,10 @@ convert (tree type, tree expr) expr), false); - return - gnat_build_constructor (type, - tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE - (TYPE_FIELDS (type)), - expr), - NULL_TREE)); + v = VEC_alloc (constructor_elt, gc, 1); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (TREE_TYPE (TYPE_FIELDS (type)), expr)); + return gnat_build_constructor (type, v); } /* If the input type has padding, remove it and convert to the output type. @@ -3771,20 +3775,19 @@ convert (tree type, tree expr) if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)) { tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); /* If the source already has a template, get a reference to the associated array only, as we are going to rebuild a template for the target type anyway. */ expr = maybe_unconstrained_array (expr); - return - gnat_build_constructor - (type, - tree_cons (TYPE_FIELDS (type), - build_template (TREE_TYPE (TYPE_FIELDS (type)), - obj_type, NULL_TREE), - tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), - convert (obj_type, expr), NULL_TREE))); + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + build_template (TREE_TYPE (TYPE_FIELDS (type)), + obj_type, NULL_TREE)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (type)), + convert (obj_type, expr)); + return gnat_build_constructor (type, v); } /* There are some special cases of expressions that we process @@ -4114,11 +4117,14 @@ convert (tree type, tree expr) case RECORD_TYPE: if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype)) - return - gnat_build_constructor - (type, tree_cons (TYPE_FIELDS (type), - convert (TREE_TYPE (TYPE_FIELDS (type)), expr), - NULL_TREE)); + { + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); + + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), + convert (TREE_TYPE (TYPE_FIELDS (type)), + expr)); + return gnat_build_constructor (type, v); + } /* ... fall through ... */ @@ -4410,11 +4416,13 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) tree rec_type = make_node (RECORD_TYPE); tree field = create_field_decl (get_identifier ("OBJ"), etype, rec_type, NULL_TREE, NULL_TREE, 1, 0); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1); TYPE_FIELDS (rec_type) = field; layout_type (rec_type); - expr = gnat_build_constructor (rec_type, build_tree_list (field, expr)); + CONSTRUCTOR_APPEND_ELT (v, field, expr); + expr = gnat_build_constructor (rec_type, v); expr = unchecked_convert (type, expr, notrunc_p); } diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 1c224a3ef07..ab3814ec4e0 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -1521,34 +1521,31 @@ build_call_raise (int msg, Node_Id gnat_node, char kind) static int compare_elmt_bitpos (const PTR rt1, const PTR rt2) { - const_tree const elmt1 = * (const_tree const *) rt1; - const_tree const elmt2 = * (const_tree const *) rt2; - const_tree const field1 = TREE_PURPOSE (elmt1); - const_tree const field2 = TREE_PURPOSE (elmt2); + const constructor_elt * const elmt1 = (const constructor_elt const *) rt1; + const constructor_elt * const elmt2 = (const constructor_elt const *) rt2; + const_tree const field1 = elmt1->index; + const_tree const field2 = elmt2->index; const int ret = tree_int_cst_compare (bit_position (field1), bit_position (field2)); return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2)); } -/* Return a CONSTRUCTOR of TYPE whose list is LIST. */ +/* Return a CONSTRUCTOR of TYPE whose elements are V. */ tree -gnat_build_constructor (tree type, tree list) +gnat_build_constructor (tree type, VEC(constructor_elt,gc) *v) { bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST); bool side_effects = false; - tree elmt, result; - int n_elmts; + tree result, obj, val; + unsigned int n_elmts; /* Scan the elements to see if they are all constant or if any has side effects, to let us set global flags on the resulting constructor. Count the elements along the way for possible sorting purposes below. */ - for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++) + FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val) { - tree obj = TREE_PURPOSE (elmt); - tree val = TREE_VALUE (elmt); - /* The predicate must be in keeping with output_constructor. */ if (!TREE_CONSTANT (val) || (TREE_CODE (type) == RECORD_TYPE @@ -1565,27 +1562,10 @@ gnat_build_constructor (tree type, tree list) by increasing bit position. This is necessary to ensure the constructor can be output as static data. */ if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1) - { - /* Fill an array with an element tree per index, and ask qsort to order - them according to what a bitpos comparison function says. */ - tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts); - int i; - - for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++) - gnu_arr[i] = elmt; + qsort (VEC_address (constructor_elt, v), n_elmts, + sizeof (constructor_elt), compare_elmt_bitpos); - qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos); - - /* Then reconstruct the list from the sorted array contents. */ - list = NULL_TREE; - for (i = n_elmts - 1; i >= 0; i--) - { - TREE_CHAIN (gnu_arr[i]) = list; - list = gnu_arr[i]; - } - } - - result = build_constructor_from_list (type, list); + result = build_constructor (type, v); TREE_CONSTANT (result) = TREE_STATIC (result) = allconstant; TREE_SIDE_EFFECTS (result) = side_effects; TREE_READONLY (result) = TYPE_READONLY (type) || allconstant; @@ -1823,13 +1803,12 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) tree malloc_ptr; - /* On VMS, if 64-bit memory is disabled or pointers are 64-bit and the - allocator size is 32-bit or Convention C, allocate 32-bit memory. */ + /* On VMS, if pointers are 64-bit and the allocator size is 32-bit or + Convention C, allocate 32-bit memory. */ if (TARGET_ABI_OPEN_VMS - && (!TARGET_MALLOC64 - || (POINTER_SIZE == 64 - && (UI_To_Int (Esize (Etype (gnat_node))) == 32 - || Convention (Etype (gnat_node)) == Convention_C)))) + && (POINTER_SIZE == 64 + && (UI_To_Int (Esize (Etype (gnat_node))) == 32 + || Convention (Etype (gnat_node)) == Convention_C))) malloc_ptr = build_call_1_expr (malloc32_decl, size_to_malloc); else malloc_ptr = build_call_1_expr (malloc_decl, size_to_malloc); @@ -1987,7 +1966,6 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type)); tree storage_ptr_type = build_pointer_type (storage_type); tree storage; - tree template_cons = NULL_TREE; size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type), init); @@ -2014,12 +1992,12 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, bounds. */ if (init) { - template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)), - init, NULL_TREE); - template_cons = tree_cons (TYPE_FIELDS (storage_type), - build_template (template_type, type, - init), - template_cons); + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); + + CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (storage_type), + build_template (template_type, type, init)); + CONSTRUCTOR_APPEND_ELT (v, TREE_CHAIN (TYPE_FIELDS (storage_type)), + init); return convert (result_type, @@ -2028,7 +2006,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, (MODIFY_EXPR, storage_type, build_unary_op (INDIRECT_REF, NULL_TREE, convert (storage_ptr_type, storage)), - gnat_build_constructor (storage_type, template_cons)), + gnat_build_constructor (storage_type, v)), convert (storage_ptr_type, storage))); } else @@ -2101,10 +2079,11 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) { tree parm_decl = get_gnu_tree (gnat_formal); tree record_type = TREE_TYPE (TREE_TYPE (parm_decl)); - tree const_list = NULL_TREE, field; + tree field; const bool do_range_check = strcmp ("MBO", IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (record_type)))); + VEC(constructor_elt,gc) *v = NULL; expr = maybe_unconstrained_array (expr); gnat_mark_addressable (expr); @@ -2136,10 +2115,10 @@ fill_vms_descriptor (tree expr, Entity_Id gnat_formal, Node_Id gnat_actual) N_Raise_Constraint_Error), NULL_TREE)); } - const_list = tree_cons (field, conexpr, const_list); + CONSTRUCTOR_APPEND_ELT (v, field, conexpr); } - return gnat_build_constructor (record_type, nreverse (const_list)); + return gnat_build_constructor (record_type, v); } /* Indicate that we need to take the address of T and that it therefore diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index da63f90e307..70d77c80b6a 100644 --- a/gcc/ada/get_scos.adb +++ b/gcc/ada/get_scos.adb @@ -54,7 +54,12 @@ procedure Get_SCOs is -- value read. Data_Error is raised for overflow (value greater than -- Int'Last), or if the initial character is not a digit. - procedure Get_Sloc_Range (Loc1, Loc2 : out Source_Location); + procedure Get_Source_Location (Loc : out Source_Location); + -- Reads a source location in the form line:col and places the source + -- location in Loc. Raises Data_Error if the format does not match this + -- requirement. Note that initial spaces are not skipped. + + procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location); -- Skips initial spaces, then reads a source location range in the form -- line:col-line:col and places the two source locations in Loc1 and Loc2. -- Raises Data_Error if format does not match this requirement. @@ -129,31 +134,32 @@ procedure Get_SCOs is raise Data_Error; end Get_Int; - -------------------- - -- Get_Sloc_Range -- - -------------------- + ------------------------- + -- Get_Source_Location -- + ------------------------- - procedure Get_Sloc_Range (Loc1, Loc2 : out Source_Location) is + procedure Get_Source_Location (Loc : out Source_Location) is pragma Unsuppress (Range_Check); - begin - Skip_Spaces; - - Loc1.Line := Logical_Line_Number (Get_Int); - Check (':'); - Loc1.Col := Column_Number (Get_Int); - - Check ('-'); - - Loc2.Line := Logical_Line_Number (Get_Int); + Loc.Line := Logical_Line_Number (Get_Int); Check (':'); - Loc2.Col := Column_Number (Get_Int); - + Loc.Col := Column_Number (Get_Int); exception when Constraint_Error => raise Data_Error; - end Get_Sloc_Range; + end Get_Source_Location; + + ------------------------------- + -- Get_Source_Location_Range -- + ------------------------------- + procedure Get_Source_Location_Range (Loc1, Loc2 : out Source_Location) is + begin + Skip_Spaces; + Get_Source_Location (Loc1); + Check ('-'); + Get_Source_Location (Loc2); + end Get_Source_Location_Range; -------------- -- Skip_EOL -- -------------- @@ -222,8 +228,8 @@ begin -- Scan out dependency number and file name declare - Ptr : String_Ptr := new String (1 .. 32768); - N : Integer; + Ptr : String_Ptr := new String (1 .. 32768); + N : Integer; begin Skip_Spaces; @@ -250,14 +256,31 @@ begin -- Statement entry - when 'S' => + when 'S' | 's' => declare Typ : Character; Key : Character; begin + -- If continuation, reset Last indication in last entry + -- stored for previous CS or cs line, and start with key + -- set to s for continuations. + + if C = 's' then + SCO_Table.Table (SCO_Table.Last).Last := False; + Key := 's'; + + -- CS case (first line, so start with key set to S) + + else + Key := 'S'; + end if; + + -- Initialize to scan items on one line + Skip_Spaces; - Key := 'S'; + + -- Loop through items on one line loop Typ := Nextc; @@ -268,7 +291,7 @@ begin Skipc; end if; - Get_Sloc_Range (Loc1, Loc2); + Get_Source_Location_Range (Loc1, Loc2); Add_SCO (C1 => Key, @@ -287,60 +310,81 @@ begin when 'I' | 'E' | 'P' | 'W' | 'X' => Dtyp := C; Skip_Spaces; - C := Getc; - -- Case of simple condition + -- Output header + + declare + Loc : Source_Location; + C2v : Character; + + begin + -- Acquire location information + + if Dtyp = 'X' then + Loc := No_Source_Location; + else + Get_Source_Location (Loc); + end if; + + -- C2 is a space except for pragmas where it is 'e' since + -- clearly the pragma is enabled if it was written out. + + if C = 'P' then + C2v := 'e'; + else + C2v := ' '; + end if; - if C = 'c' or else C = 't' or else C = 'f' then - Cond := C; - Get_Sloc_Range (Loc1, Loc2); Add_SCO (C1 => Dtyp, - C2 => Cond, - From => Loc1, - To => Loc2, - Last => True); + C2 => C2v, + From => Loc, + To => No_Source_Location, + Last => False); + end; - -- Complex expression + -- Loop through terms in complex expression - else - Add_SCO (C1 => Dtyp, Last => False); + C := Nextc; + while C /= CR and then C /= LF loop + if C = 'c' or else C = 't' or else C = 'f' then + Cond := C; + Skipc; + Get_Source_Location_Range (Loc1, Loc2); + Add_SCO + (C2 => Cond, + From => Loc1, + To => Loc2, + Last => False); - -- Loop through terms in complex expression + elsif C = '!' or else + C = '&' or else + C = '|' + then + Skipc; - while C /= CR and then C /= LF loop - if C = 'c' or else C = 't' or else C = 'f' then - Cond := C; - Skipc; - Get_Sloc_Range (Loc1, Loc2); - Add_SCO - (C2 => Cond, - From => Loc1, - To => Loc2, - Last => False); - - elsif C = '!' or else - C = '^' or else - C = '&' or else - C = '|' - then - Skipc; - Add_SCO (C1 => C, Last => False); + declare + Loc : Source_Location; + begin + Get_Source_Location (Loc); + Add_SCO (C1 => C, From => Loc, Last => False); + end; - elsif C = ' ' then - Skip_Spaces; + elsif C = ' ' then + Skip_Spaces; - else - raise Data_Error; - end if; + else + raise Data_Error; + end if; - C := Nextc; - end loop; + C := Nextc; + end loop; - -- Reset Last indication to True for last entry + -- Reset Last indication to True for last entry - SCO_Table.Table (SCO_Table.Last).Last := True; - end if; + SCO_Table.Table (SCO_Table.Last).Last := True; + + -- No other SCO lines are possible when others => raise Data_Error; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 79824868be5..d3d15ccc3b1 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -30,6 +30,7 @@ with Csets; use Csets; with Debug; use Debug; with Elists; with Errout; use Errout; +with Exp_CG; with Fmap; with Fname; use Fname; with Fname.UF; use Fname.UF; @@ -49,6 +50,7 @@ with Par_SCO; with Prepcomp; with Repinfo; use Repinfo; with Restrict; +with Rident; use Rident; with Rtsfind; with SCOs; with Sem; @@ -168,12 +170,14 @@ procedure Gnat1drv is Optimization_Level := 0; - -- Disable specific expansions for Restrictions pragmas to avoid - -- tree inconsistencies between compilations with different pragmas - -- that will cause different SCIL files to be generated for the - -- same Ada spec. + -- Enable some restrictions systematically to simplify the generated + -- code (and ease analysis). Note that restriction checks are also + -- disabled in CodePeer_Mode, see Restrict.Check_Restriction - Treat_Restrictions_As_Warnings := True; + Restrict.Restrictions.Set (No_Task_Hierarchy) := True; + Restrict.Restrictions.Set (No_Abort_Statements) := True; + Restrict.Restrictions.Set (Max_Asynchronous_Select_Nesting) := True; + Restrict.Restrictions.Value (Max_Asynchronous_Select_Nesting) := 0; -- Suppress overflow, division by zero and access checks since they -- are handled implicitly by CodePeer. @@ -332,6 +336,53 @@ procedure Gnat1drv is else Suppress_Options (Overflow_Check) := True; end if; + + -- Set switch indicating if we can use N_Expression_With_Actions + + -- Debug flag -gnatd.X decisively sets usage on + + if Debug_Flag_Dot_XX then + Use_Expression_With_Actions := True; + + -- Debug flag -gnatd.Y decisively sets usage off + + elsif Debug_Flag_Dot_YY then + Use_Expression_With_Actions := False; + + -- If no debug flags, usage off for SCIL + + elsif Generate_SCIL then + Use_Expression_With_Actions := False; + + -- Otherwise this feature is implemented, so we allow its use + + else + Use_Expression_With_Actions := True; + end if; + + -- Set switch indicating if back end can handle limited types, and + -- guarantee that no incorrect copies are made (e.g. in the context + -- of a conditional expression). + + -- Debug flag -gnatd.L decisively sets usage on + + if Debug_Flag_Dot_LL then + Back_End_Handles_Limited_Types := True; + + -- If no debug flag, usage off for AAMP, VM, SCIL cases + + elsif AAMP_On_Target + or else VM_Target /= No_VM + or else Generate_SCIL + then + Back_End_Handles_Limited_Types := False; + + -- Otherwise normal gcc back end, for now still turn flag off by + -- default, since there are unresolved problems in the front end. + + else + Back_End_Handles_Limited_Types := False; + end if; end Adjust_Global_Switches; -------------------- @@ -549,6 +600,7 @@ begin Nlists.Initialize; Sinput.Initialize; Sem.Initialize; + Exp_CG.Initialize; Csets.Initialize; Uintp.Initialize; Urealp.Initialize; @@ -812,42 +864,28 @@ begin if Subunits_Missing then Write_Str (" (missing subunits)"); Write_Eol; - Write_Str ("to check parent unit"); elsif Main_Kind = N_Subunit then Write_Str (" (subunit)"); Write_Eol; - Write_Str ("to check subunit"); elsif Main_Kind = N_Subprogram_Declaration then Write_Str (" (subprogram spec)"); Write_Eol; - Write_Str ("to check subprogram spec"); -- Generic package body in GNAT implementation mode elsif Main_Kind = N_Package_Body and then GNAT_Mode then Write_Str (" (predefined generic)"); Write_Eol; - Write_Str ("to check predefined generic"); -- Only other case is a package spec else Write_Str (" (package spec)"); Write_Eol; - Write_Str ("to check package spec"); end if; - Write_Str (" for errors, use "); - - if Hostparm.OpenVMS then - Write_Str ("/NOLOAD"); - else - Write_Str ("-gnatc"); - end if; - - Write_Eol; Set_Standard_Output; Sem_Ch13.Validate_Unchecked_Conversions; @@ -938,6 +976,10 @@ begin Namet.Unlock; + -- Generate the call-graph output of dispatching calls + + Exp_CG.Generate_CG_Output; + -- Validate unchecked conversions (using the values for size and -- alignment annotated by the backend where possible). diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 7f7e179b499..e4a39e1671b 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -81,7 +81,6 @@ AdaCore * Interfacing to Other Languages:: * Specialized Needs Annexes:: * Implementation of Specific Ada Features:: -* Project File Reference:: * Obsolescent Features:: * GNU Free Documentation License:: * Index:: @@ -100,6 +99,8 @@ Implementation Defined Pragmas * Pragma Ada_95:: * Pragma Ada_05:: * Pragma Ada_2005:: +* Pragma Ada_12:: +* Pragma Ada_2012:: * Pragma Annotate:: * Pragma Assert:: * Pragma Assume_No_Invalid_Values:: @@ -133,6 +134,7 @@ Implementation Defined Pragmas * Pragma Export_Value:: * Pragma Export_Valued_Procedure:: * Pragma Extend_System:: +* Pragma Extensions_Allowed:: * Pragma External:: * Pragma External_Name_Casing:: * Pragma Fast_Math:: @@ -364,6 +366,8 @@ The GNAT Library * GNAT.IO (g-io.ads):: * GNAT.IO_Aux (g-io_aux.ads):: * GNAT.Lock_Files (g-locfil.ads):: +* GNAT.MBBS_Discrete_Random (g-mbdira.ads):: +* GNAT.MBBS_Float_Random (g-mbflra.ads):: * GNAT.MD5 (g-md5.ads):: * GNAT.Memory_Dump (g-memdum.ads):: * GNAT.Most_Recent_Exception (g-moreex.ads):: @@ -463,8 +467,6 @@ Implementation of Specific Ada Features * The Size of Discriminated Records with Default Discriminants:: * Strict Conformance to the Ada Reference Manual:: -Project File Reference - Obsolescent Features GNU Free Documentation License @@ -582,10 +584,6 @@ to GNAT's implementation of machine code insertions, tasking, and several other features. @item -@ref{Project File Reference}, presents the syntax and semantics -of project files. - -@item @ref{Obsolescent Features} documents implementation dependent features, including pragmas and attributes, which are considered obsolescent, since there are other preferred ways of achieving the same results. These @@ -717,6 +715,8 @@ consideration, the use of these pragmas should be minimized. * Pragma Ada_95:: * Pragma Ada_05:: * Pragma Ada_2005:: +* Pragma Ada_12:: +* Pragma Ada_2012:: * Pragma Annotate:: * Pragma Assert:: * Pragma Assume_No_Invalid_Values:: @@ -750,6 +750,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Export_Value:: * Pragma Export_Valued_Procedure:: * Pragma Extend_System:: +* Pragma Extensions_Allowed:: * Pragma External:: * Pragma External_Name_Casing:: * Pragma Fast_Math:: @@ -908,9 +909,7 @@ pragma Ada_05; @noindent A configuration pragma that establishes Ada 2005 mode for the unit to which it applies, regardless of the mode set by the command line switches. -This mode is set automatically for the @code{Ada} and @code{System} -packages and their children, so you need not specify it in these -contexts. This pragma is useful when writing a reusable component that +This pragma is useful when writing a reusable component that itself uses Ada 2005 features, but which is intended to be usable from either Ada 83 or Ada 95 programs. @@ -927,6 +926,37 @@ pragma Ada_2005; This configuration pragma is a synonym for pragma Ada_05 and has the same syntax and effect. +@node Pragma Ada_12 +@unnumberedsec Pragma Ada_12 +@findex Ada_12 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_12; +@end smallexample + +@noindent +A configuration pragma that establishes Ada 2012 mode for the unit to which +it applies, regardless of the mode set by the command line switches. +This mode is set automatically for the @code{Ada} and @code{System} +packages and their children, so you need not specify it in these +contexts. This pragma is useful when writing a reusable component that +itself uses Ada 2012 features, but which is intended to be usable from +Ada 83, Ada 95, or Ada 2005 programs. + +@node Pragma Ada_2012 +@unnumberedsec Pragma Ada_2012 +@findex Ada_2005 +@noindent +Syntax: +@smallexample @c ada +pragma Ada_2012; +@end smallexample + +@noindent +This configuration pragma is a synonym for pragma Ada_12 and has the +same syntax and effect. + @node Pragma Annotate @unnumberedsec Pragma Annotate @findex Annotate @@ -2179,6 +2209,35 @@ it you will have to use the appropriate switch for compiling system units. @xref{Top, @value{EDITION} User's Guide, About This Guide,, gnat_ugn, @value{EDITION} User's Guide}, for details. +@node Pragma Extensions_Allowed +@unnumberedsec Pragma Extensions_Allowed +@cindex Ada Extensions +@cindex GNAT Extensions +@findex Extensions_Allowed +@noindent +Syntax: + +@smallexample @c ada +pragma Extensions_Allowed (On | Off); +@end smallexample + +@noindent +This configuration pragma enables or disables the implementation +extension mode (the use of Off as a parameter cancels the effect +of the @option{-gnatX} command switch). + +In extension mode, the latest version of the Ada language is +implemented (currently Ada 2012), and in addition a small number +of GNAT specific extensions are recognized as follows: + +@table @asis +@item Constrained attribute for generic objects +The @code{Constrained} attribute is permitted for objects of +generic types. The result indicates if the corresponding actual +is constrained. + +@end table + @node Pragma External @unnumberedsec Pragma External @findex External @@ -2856,7 +2915,12 @@ the standard Ada pragma @code{Import}. It is provided for compatibility with Ada 83. The definition is upwards compatible both with pragma @code{Interface} as defined in the Ada 83 Reference Manual, and also with some extended implementations of this pragma in certain Ada 83 -implementations. +implementations. The only difference between pragma @code{Interface} +and pragma @code{Import} is that there is special circuitry to allow +both pragmas to appear for the same subprogram entity (normally it +is illegal to have multiple @code{Import} pragmas. This is useful in +maintaining Ada 83/Ada 95 compatibility and is compatible with other +Ada 83 compilers. @node Pragma Interface_Name @unnumberedsec Pragma Interface_Name @@ -2923,7 +2987,7 @@ Ada exceptions, or used to implement run-time functions such as the Pragma @code{Interrupt_State} provides a general mechanism for overriding such uses of interrupts. It subsumes the functionality of pragma @code{Unreserve_All_Interrupts}. Pragma @code{Interrupt_State} is not -available on OS/2, Windows or VMS. On all other platforms than VxWorks, +available on Windows or VMS. On all other platforms than VxWorks, it applies to signals; on VxWorks, it applies to vectored hardware interrupts and may be used to mark interrupts required by the board support package as reserved. @@ -3967,8 +4031,6 @@ inlining (-gnatN option set) are accepted and legality-checked by the compiler, but are ignored at run-time even if postcondition checking is enabled. - - @node Pragma Profile (Ravenscar) @unnumberedsec Pragma Profile (Ravenscar) @findex Ravenscar @@ -4533,7 +4595,11 @@ gcc -c -gnatyl @dots{} The form ALL_CHECKS activates all standard checks (its use is equivalent to the use of the @code{gnaty} switch with no options. @xref{Top, @value{EDITION} User's Guide, About This Guide, gnat_ugn, -@value{EDITION} User's Guide}, for details. +@value{EDITION} User's Guide}, for details.) + +Note: the behavior is slightly different in GNAT mode (@option{-gnatg} used). +In this case, ALL_CHECKS implies the standard set of GNAT mode style check +options (i.e. equivalent to -gnatyg). The forms with @code{Off} and @code{On} can be used to temporarily disable style checks @@ -5249,6 +5315,9 @@ used to cause the compiler to entirely ignore all WARNINGS pragmas. This can be useful in checking whether obsolete pragmas in existing programs are hiding real problems. +Note: pragma Warnings does not affect the processing of style messages. See +separate entry for pragma Style_Checks for control of style messages. + @node Pragma Weak_External @unnumberedsec Pragma Weak_External @findex Weak_External @@ -5946,7 +6015,7 @@ end record; @end smallexample @noindent -will have a size of 40 (that is @code{Rec'Size} will be 40. The +will have a size of 40 (that is @code{Rec'Size} will be 40). The alignment will be 4, because of the integer field, and so the default size of record objects for this type will be 64 (8 bytes). @@ -6575,7 +6644,6 @@ For example: for Y'Address use X'Address;>> @end smallexample - @sp 1 @cartouche An implementation need not support a specification for the @code{Size} @@ -8846,7 +8914,7 @@ floating-point. @code{Numerics.Float_Random.Max_Image_Width}. See A.5.2(27). @end cartouche @noindent -Maximum image width is 649, see library file @file{a-numran.ads}. +Maximum image width is 6864, see library file @file{s-rannum.ads}. @sp 1 @cartouche @@ -8855,7 +8923,7 @@ Maximum image width is 649, see library file @file{a-numran.ads}. @code{Numerics.Discrete_Random.Max_Image_Width}. See A.5.2(27). @end cartouche @noindent -Maximum image width is 80, see library file @file{a-nudira.ads}. +Maximum image width is 6864, see library file @file{s-rannum.ads}. @sp 1 @cartouche @@ -8864,8 +8932,9 @@ Maximum image width is 80, see library file @file{a-nudira.ads}. A.5.2(32). @end cartouche @noindent -The algorithm is documented in the source files @file{a-numran.ads} and -@file{a-numran.adb}. +The algorithm is the Mersenne Twister, as documented in the source file +@file{s-rannum.adb}. This version of the algorithm has a period of +2**19937-1. @sp 1 @cartouche @@ -8874,7 +8943,9 @@ The algorithm is documented in the source files @file{a-numran.ads} and state. See A.5.2(38). @end cartouche @noindent -See the documentation contained in the file @file{a-numran.adb}. +The value returned by the Image function is the concatenation of +the fixed-width decimal representations of the 624 32-bit integers +of the state vector. @sp 1 @cartouche @@ -11837,12 +11908,12 @@ This is a predefined instantiation of build the type @code{Complex} and @code{Imaginary}. @item Ada.Numerics.Discrete_Random -This package provides a random number generator suitable for generating -random integer values from a specified range. +This generic package provides a random number generator suitable for generating +uniformly distributed values of a specified discrete subtype. @item Ada.Numerics.Float_Random This package provides a random number generator suitable for generating -uniformly distributed floating point values. +uniformly distributed floating point values in the unit interval. @item Ada.Numerics.Generic_Complex_Elementary_Functions This is a generic version of the package that provides the @@ -12225,8 +12296,6 @@ types are @code{Wide_Character} and @code{Wide_String} instead of @code{Character} and @code{String}. @end table - - @node The Implementation of Standard I/O @chapter The Implementation of Standard I/O @@ -13241,8 +13310,8 @@ package Interfaces.C_Streams is -- Standard C functions -- -------------------------- -- The functions selected below are ones that are - -- available in DOS, OS/2, UNIX and Xenix (but not - -- necessarily in ANSI C). These are very thin interfaces + -- available in UNIX (but not necessarily in ANSI C). + -- These are very thin interfaces -- which copy exactly the C headers. For more -- documentation on these functions, see the Microsoft C -- "Run-Time Library Reference" (Microsoft Press, 1990, @@ -13545,6 +13614,8 @@ of GNAT, and will generate a warning message. * GNAT.IO (g-io.ads):: * GNAT.IO_Aux (g-io_aux.ads):: * GNAT.Lock_Files (g-locfil.ads):: +* GNAT.MBBS_Discrete_Random (g-mbdira.ads):: +* GNAT.MBBS_Float_Random (g-mbflra.ads):: * GNAT.MD5 (g-md5.ads):: * GNAT.Memory_Dump (g-memdum.ads):: * GNAT.Most_Recent_Exception (g-moreex.ads):: @@ -14429,6 +14500,24 @@ for whether a file exists, and functions for reading a line of text. 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) +@section @code{GNAT.MBBS_Discrete_Random} (@file{g-mbdira.ads}) +@cindex @code{GNAT.MBBS_Discrete_Random} (@file{g-mbdira.ads}) +@cindex Random number generation + +@noindent +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) +@section @code{GNAT.MBBS_Float_Random} (@file{g-mbflra.ads}) +@cindex @code{GNAT.MBBS_Float_Random} (@file{g-mbflra.ads}) +@cindex Random number generation + +@noindent +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) @section @code{GNAT.MD5} (@file{g-md5.ads}) @cindex @code{GNAT.MD5} (@file{g-md5.ads}) @@ -15477,7 +15566,7 @@ the underlying kernel. Otherwise, some target dependent glue code maps the services offered by the underlying kernel to the semantics expected by GNARL@. -Whatever the underlying OS (VxWorks, UNIX, OS/2, Windows NT, etc.) the +Whatever the underlying OS (VxWorks, UNIX, Windows, etc.) the key point is that each Ada task is mapped on a thread in the underlying kernel. For example, in the case of VxWorks, one Ada task = one VxWorks task. @@ -15822,7 +15911,6 @@ If any of these conditions are violated, the aggregate will be built in 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 @section The Size of Discriminated Records with Default Discriminants @@ -15939,1135 +16027,6 @@ machines that are not fully compliant with this standard, such as Alpha, the behavior (although at the cost of a significant performance penalty), so infinite and and NaN values are properly generated. - -@node Project File Reference -@chapter Project File Reference - -@noindent -This chapter describes the syntax and semantics of project files. -Project files specify the options to be used when building a system. -Project files can specify global settings for all tools, -as well as tool-specific settings. -@xref{Examples of Project Files,,, gnat_ugn, @value{EDITION} User's Guide}, -for examples of use. - -@menu -* Reserved Words:: -* Lexical Elements:: -* Declarations:: -* Empty declarations:: -* Typed string declarations:: -* Variables:: -* Expressions:: -* Attributes:: -* Project Attributes:: -* Attribute References:: -* External Values:: -* Case Construction:: -* Packages:: -* Package Renamings:: -* Projects:: -* Project Extensions:: -* Project File Elaboration:: -@end menu - -@node Reserved Words -@section Reserved Words - -@noindent -All Ada reserved words are reserved in project files, and cannot be used -as variable names or project names. In addition, the following are -also reserved in project files: - -@itemize -@item @code{extends} - -@item @code{external} - -@item @code{project} - -@end itemize - -@node Lexical Elements -@section Lexical Elements - -@noindent -Rules for identifiers are the same as in Ada. Identifiers -are case-insensitive. Strings are case sensitive, except where noted. -Comments have the same form as in Ada. - -@noindent -Syntax: - -@smallexample -simple_name ::= - identifier - -name ::= - simple_name @{. simple_name@} -@end smallexample - -@node Declarations -@section Declarations - -@noindent -Declarations introduce new entities that denote types, variables, attributes, -and packages. Some declarations can only appear immediately within a project -declaration. Others can appear within a project or within a package. - -Syntax: -@smallexample -declarative_item ::= - simple_declarative_item | - typed_string_declaration | - package_declaration - -simple_declarative_item ::= - variable_declaration | - typed_variable_declaration | - attribute_declaration | - case_construction | - empty_declaration -@end smallexample - -@node Empty declarations -@section Empty declarations - -@smallexample -empty_declaration ::= - @b{null} ; -@end smallexample - -An empty declaration is allowed anywhere a declaration is allowed. -It has no effect. - -@node Typed string declarations -@section Typed string declarations - -@noindent -Typed strings are sequences of string literals. Typed strings are the only -named types in project files. They are used in case constructions, where they -provide support for conditional attribute definitions. - -Syntax: -@smallexample -typed_string_declaration ::= - @b{type} <typed_string_>_simple_name @b{is} - ( string_literal @{, string_literal@} ); -@end smallexample - -@noindent -A typed string declaration can only appear immediately within a project -declaration. - -All the string literals in a typed string declaration must be distinct. - -@node Variables -@section Variables - -@noindent -Variables denote values, and appear as constituents of expressions. - -@smallexample -typed_variable_declaration ::= - <typed_variable_>simple_name : <typed_string_>name := string_expression ; - -variable_declaration ::= - <variable_>simple_name := expression; -@end smallexample - -@noindent -The elaboration of a variable declaration introduces the variable and -assigns to it the value of the expression. The name of the variable is -available after the assignment symbol. - -@noindent -A typed_variable can only be declare once. - -@noindent -a non-typed variable can be declared multiple times. - -@noindent -Before the completion of its first declaration, the value of variable -is the null string. - -@node Expressions -@section Expressions - -@noindent -An expression is a formula that defines a computation or retrieval of a value. -In a project file the value of an expression is either a string or a list -of strings. A string value in an expression is either a literal, the current -value of a variable, an external value, an attribute reference, or a -concatenation operation. - -Syntax: - -@smallexample -expression ::= - term @{& term@} - -term ::= - string_literal | - string_list | - <variable_>name | - external_value | - attribute_reference - -string_literal ::= - (same as Ada) - -string_list ::= - ( <string_>expression @{ , <string_>expression @} ) -@end smallexample - -@subsection Concatenation -@noindent -The following concatenation functions are defined: - -@smallexample @c ada - function "&" (X : String; Y : String) return String; - function "&" (X : String_List; Y : String) return String_List; - function "&" (X : String_List; Y : String_List) return String_List; -@end smallexample - -@node Attributes -@section Attributes - -@noindent -An attribute declaration defines a property of a project or package. This -property can later be queried by means of an attribute reference. -Attribute values are strings or string lists. - -Some attributes are associative arrays. These attributes are mappings whose -domain is a set of strings. These attributes are declared one association -at a time, by specifying a point in the domain and the corresponding image -of the attribute. They may also be declared as a full associative array, -getting the same associations as the corresponding attribute in an imported -or extended project. - -Attributes that are not associative arrays are called simple attributes. - -Syntax: -@smallexample -attribute_declaration ::= - full_associative_array_declaration | - @b{for} attribute_designator @b{use} expression ; - -full_associative_array_declaration ::= - @b{for} <associative_array_attribute_>simple_name @b{use} - <project_>simple_name [ . <package_>simple_Name ] ' <attribute_>simple_name ; - -attribute_designator ::= - <simple_attribute_>simple_name | - <associative_array_attribute_>simple_name ( string_literal ) -@end smallexample - -@noindent -Some attributes are project-specific, and can only appear immediately within -a project declaration. Others are package-specific, and can only appear within -the proper package. - -The expression in an attribute definition must be a string or a string_list. -The string literal appearing in the attribute_designator of an associative -array attribute is case-insensitive. - -@node Project Attributes -@section Project Attributes - -@noindent -The following attributes apply to a project. All of them are simple -attributes. - -@table @code -@item Object_Dir -Expression must be a path name. The attribute defines the -directory in which the object files created by the build are to be placed. If -not specified, object files are placed in the project directory. - -@item Exec_Dir -Expression must be a path name. The attribute defines the -directory in which the executables created by the build are to be placed. -If not specified, executables are placed in the object directory. - -@item Source_Dirs -Expression must be a list of path names. The attribute -defines the directories in which the source files for the project are to be -found. If not specified, source files are found in the project directory. -If a string in the list ends with "/**", then the directory that precedes -"/**" and all of its subdirectories (recursively) are included in the list -of source directories. - -@item Excluded_Source_Dirs -Expression must be a list of strings. Each entry designates a directory that -is not to be included in the list of source directories of the project. -This is normally used when there are strings ending with "/**" in the value -of attribute Source_Dirs. - -@item Source_Files -Expression must be a list of file names. The attribute -defines the individual files, in the project directory, which are to be used -as sources for the project. File names are path_names that contain no directory -information. If the project has no sources the attribute must be declared -explicitly with an empty list. - -@item Excluded_Source_Files (Locally_Removed_Files) -Expression must be a list of strings that are legal file names. -Each file name must designate a source that would normally be a source file -in the source directories of the project or, if the project file is an -extending project file, inherited by the current project file. It cannot -designate an immediate source that is not inherited. Each of the source files -in the list are not considered to be sources of the project file: they are not -inherited. Attribute Locally_Removed_Files is obsolescent, attribute -Excluded_Source_Files is preferred. - -@item Source_List_File -Expression must a single path name. The attribute -defines a text file that contains a list of source file names to be used -as sources for the project - -@item Library_Dir -Expression must be a path name. The attribute defines the -directory in which a library is to be built. The directory must exist, must -be distinct from the project's object directory, and must be writable. - -@item Library_Name -Expression must be a string that is a legal file name, -without extension. The attribute defines a string that is used to generate -the name of the library to be built by the project. - -@item Library_Kind -Argument must be a string value that must be one of the -following @code{"static"}, @code{"dynamic"} or @code{"relocatable"}. This -string is case-insensitive. If this attribute is not specified, the library is -a static library. Otherwise, the library may be dynamic or relocatable. This -distinction is operating-system dependent. - -@item Library_Version -Expression must be a string value whose interpretation -is platform dependent. On UNIX, it is used only for dynamic/relocatable -libraries as the internal name of the library (the @code{"soname"}). If the -library file name (built from the @code{Library_Name}) is different from the -@code{Library_Version}, then the library file will be a symbolic link to the -actual file whose name will be @code{Library_Version}. - -@item Library_Interface -Expression must be a string list. Each element of the string list -must designate a unit of the project. -If this attribute is present in a Library Project File, then the project -file is a Stand-alone Library_Project_File. - -@item Library_Auto_Init -Expression must be a single string "true" or "false", case-insensitive. -If this attribute is present in a Stand-alone Library Project File, -it indicates if initialization is automatic when the dynamic library -is loaded. - -@item Library_Options -Expression must be a string list. Indicates additional switches that -are to be used when building a shared library. - -@item Library_GCC -Expression must be a single string. Designates an alternative to "gcc" -for building shared libraries. - -@item Library_Src_Dir -Expression must be a path name. The attribute defines the -directory in which the sources of the interfaces of a Stand-alone Library will -be copied. The directory must exist, must be distinct from the project's -object directory and source directories of all projects in the project tree, -and must be writable. - -@item Library_Src_Dir -Expression must be a path name. The attribute defines the -directory in which the ALI files of a Library will -be copied. The directory must exist, must be distinct from the project's -object directory and source directories of all projects in the project tree, -and must be writable. - -@item Library_Symbol_File -Expression must be a single string. Its value is the single file name of a -symbol file to be created when building a stand-alone library when the -symbol policy is either "compliant", "controlled" or "restricted", -on platforms that support symbol control, such as VMS. When symbol policy -is "direct", then a file with this name must exist in the object directory. - -@item Library_Reference_Symbol_File -Expression must be a single string. Its value is the path name of a -reference symbol file that is read when the symbol policy is either -"compliant" or "controlled", on platforms that support symbol control, -such as VMS, when building a stand-alone library. The path may be an absolute -path or a path relative to the project directory. - -@item Library_Symbol_Policy -Expression must be a single string. Its case-insensitive value can only be -"autonomous", "default", "compliant", "controlled", "restricted" or "direct". - -This attribute is not taken into account on all platforms. It controls the -policy for exported symbols and, on some platforms (like VMS) that have the -notions of major and minor IDs built in the library files, it controls -the setting of these IDs. - -"autonomous" or "default": exported symbols are not controlled. - -"compliant": if attribute Library_Reference_Symbol_File is not defined, then -it is equivalent to policy "autonomous". If there are exported symbols in -the reference symbol file that are not in the object files of the interfaces, -the major ID of the library is increased. If there are symbols in the -object files of the interfaces that are not in the reference symbol file, -these symbols are put at the end of the list in the newly created symbol file -and the minor ID is increased. - -"controlled": the attribute Library_Reference_Symbol_File must be defined. -The library will fail to build if the exported symbols in the object files of -the interfaces do not match exactly the symbol in the symbol file. - -"restricted": The attribute Library_Symbol_File must be defined. The library -will fail to build if there are symbols in the symbol file that are not in -the exported symbols of the object files of the interfaces. Additional symbols -in the object files are not added to the symbol file. - -"direct": The attribute Library_Symbol_File must be defined and must designate -an existing file in the object directory. This symbol file is passed directly -to the underlying linker without any symbol processing. - -@item Main -Expression must be a list of strings that are legal file names. -These file names designate existing compilation units in the source directory -that are legal main subprograms. - -When a project file is elaborated, as part of the execution of a gnatmake -command, one or several executables are built and placed in the Exec_Dir. -If the gnatmake command does not include explicit file names, the executables -that are built correspond to the files specified by this attribute. - -@item Externally_Built -Expression must be a single string. Its value must be either "true" of "false", -case-insensitive. The default is "false". When the value of this attribute is -"true", no attempt is made to compile the sources or to build the library, -when the project is a library project. - -@item Main_Language -This is a simple attribute. Its value is a string that specifies the -language of the main program. - -@item Languages -Expression must be a string list. Each string designates -a programming language that is known to GNAT. The strings are case-insensitive. - -@end table - -@node Attribute References -@section Attribute References - -@noindent -Attribute references are used to retrieve the value of previously defined -attribute for a package or project. -Syntax: -@smallexample -attribute_reference ::= - attribute_prefix ' <simple_attribute_>simple_name [ ( string_literal ) ] - -attribute_prefix ::= - @b{project} | - <project_simple_name | package_identifier | - <project_>simple_name . package_identifier -@end smallexample - -@noindent -If an attribute has not been specified for a given package or project, its -value is the null string or the empty list. - -@node External Values -@section External Values - -@noindent -An external value is an expression whose value is obtained from the command -that invoked the processing of the current project file (typically a -gnatmake command). - -Syntax: -@smallexample -external_value ::= - @b{external} ( string_literal [, string_literal] ) -@end smallexample - -@noindent -The first string_literal is the string to be used on the command line or -in the environment to specify the external value. The second string_literal, -if present, is the default to use if there is no specification for this -external value either on the command line or in the environment. - -@node Case Construction -@section Case Construction - -@noindent -A case construction supports attribute and variable declarations that depend -on the value of a previously declared variable. - -Syntax: -@smallexample -case_construction ::= - @b{case} <typed_variable_>name @b{is} - @{case_item@} - @b{end case} ; - -case_item ::= - @b{when} discrete_choice_list => - @{case_construction | - attribute_declaration | - variable_declaration | - empty_declaration@} - -discrete_choice_list ::= - string_literal @{| string_literal@} | - @b{others} -@end smallexample - -@noindent -Inside a case construction, variable declarations must be for variables that -have already been declared before the case construction. - -All choices in a choice list must be distinct. The choice lists of two -distinct alternatives must be disjoint. Unlike Ada, the choice lists of all -alternatives do not need to include all values of the type. An @code{others} -choice must appear last in the list of alternatives. - -@node Packages -@section Packages - -@noindent -A package provides a grouping of variable declarations and attribute -declarations to be used when invoking various GNAT tools. The name of -the package indicates the tool(s) to which it applies. -Syntax: - -@smallexample -package_declaration ::= - package_spec | package_renaming - -package_spec ::= - @b{package} package_identifier @b{is} - @{simple_declarative_item@} - @b{end} package_identifier ; - -package_identifier ::= - @code{Naming} | @code{Builder} | @code{Compiler} | @code{Binder} | - @code{Linker} | @code{Finder} | @code{Cross_Reference} | - @code{gnatls} | @code{IDE} | @code{Pretty_Printer} | @code{Check} -@end smallexample - -@subsection Package Naming - -@noindent -The attributes of a @code{Naming} package specifies the naming conventions -that apply to the source files in a project. When invoking other GNAT tools, -they will use the sources in the source directories that satisfy these -naming conventions. - -The following attributes apply to a @code{Naming} package: - -@table @code -@item Casing -This is a simple attribute whose value is a string. Legal values of this -string are @code{"lowercase"}, @code{"uppercase"} or @code{"mixedcase"}. -These strings are themselves case insensitive. - -@noindent -If @code{Casing} is not specified, then the default is @code{"lowercase"}. - -@item Dot_Replacement -This is a simple attribute whose string value satisfies the following -requirements: - -@itemize @bullet -@item It must not be empty -@item It cannot start or end with an alphanumeric character -@item It cannot be a single underscore -@item It cannot start with an underscore followed by an alphanumeric -@item It cannot contain a dot @code{'.'} if longer than one character -@end itemize - -@noindent -If @code{Dot_Replacement} is not specified, then the default is @code{"-"}. - -@item Spec_Suffix -This is an associative array attribute, defined on language names, -whose image is a string that must satisfy the following -conditions: - -@itemize @bullet -@item It must not be empty -@item It cannot start with an alphanumeric character -@item It cannot start with an underscore followed by an alphanumeric character -@end itemize - -@noindent -For Ada, the attribute denotes the suffix used in file names that contain -library unit declarations, that is to say units that are package and -subprogram declarations. If @code{Spec_Suffix ("Ada")} is not -specified, then the default is @code{".ads"}. - -For C and C++, the attribute denotes the suffix used in file names that -contain prototypes. - -@item Body_Suffix -This is an associative array attribute defined on language names, -whose image is a string that must satisfy the following -conditions: - -@itemize @bullet -@item It must not be empty -@item It cannot start with an alphanumeric character -@item It cannot start with an underscore followed by an alphanumeric character -@item It cannot be a suffix of @code{Spec_Suffix} -@end itemize - -@noindent -For Ada, the attribute denotes the suffix used in file names that contain -library bodies, that is to say units that are package and subprogram bodies. -If @code{Body_Suffix ("Ada")} is not specified, then the default is -@code{".adb"}. - -For C and C++, the attribute denotes the suffix used in file names that contain -source code. - -@item Separate_Suffix -This is a simple attribute whose value satisfies the same conditions as -@code{Body_Suffix}. - -This attribute is specific to Ada. It denotes the suffix used in file names -that contain separate bodies. If it is not specified, then it defaults to same -value as @code{Body_Suffix ("Ada")}. - -@item Spec -This is an associative array attribute, specific to Ada, defined over -compilation unit names. The image is a string that is the name of the file -that contains that library unit. The file name is case sensitive if the -conventions of the host operating system require it. - -@item Body -This is an associative array attribute, specific to Ada, defined over -compilation unit names. The image is a string that is the name of the file -that contains the library unit body for the named unit. The file name is case -sensitive if the conventions of the host operating system require it. - -@item Specification_Exceptions -This is an associative array attribute defined on language names, -whose value is a list of strings. - -This attribute is not significant for Ada. - -For C and C++, each string in the list denotes the name of a file that -contains prototypes, but whose suffix is not necessarily the -@code{Spec_Suffix} for the language. - -@item Implementation_Exceptions -This is an associative array attribute defined on language names, -whose value is a list of strings. - -This attribute is not significant for Ada. - -For C and C++, each string in the list denotes the name of a file that -contains source code, but whose suffix is not necessarily the -@code{Body_Suffix} for the language. -@end table - -The following attributes of package @code{Naming} are obsolescent. They are -kept as synonyms of other attributes for compatibility with previous versions -of the Project Manager. - -@table @code -@item Specification_Suffix -This is a synonym of @code{Spec_Suffix}. - -@item Implementation_Suffix -This is a synonym of @code{Body_Suffix}. - -@item Specification -This is a synonym of @code{Spec}. - -@item Implementation -This is a synonym of @code{Body}. -@end table - -@subsection package Compiler - -@noindent -The attributes of the @code{Compiler} package specify the compilation options -to be used by the underlying compiler. - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies the compilation options to be used when compiling a component -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies the -compilation options to be used when compiling the named file. If a file -is not specified in the Switches attribute, it is compiled with the -options specified by Default_Switches of its language, if defined. - -@item Local_Configuration_Pragmas. -This is a simple attribute, whose -value is a path name that designates a file containing configuration pragmas -to be used for all invocations of the compiler for immediate sources of the -project. -@end table - -@subsection package Builder - -@noindent -The attributes of package @code{Builder} specify the compilation, binding, and -linking options to be used when building an executable for a project. The -following attributes apply to package @code{Builder}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when building a main -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when building the named main file. If a main file -is not specified in the Switches attribute, it is built with the -options specified by Default_Switches of its language, if defined. - -@item Global_Configuration_Pragmas -This is a simple attribute, whose -value is a path name that designates a file that contains configuration pragmas -to be used in every build of an executable. If both local and global -configuration pragmas are specified, a compilation makes use of both sets. - - -@item Executable -This is an associative array attribute. Its domain is -a set of main source file names. Its range is a simple string that specifies -the executable file name to be used when linking the specified main source. -If a main source is not specified in the Executable attribute, the executable -file name is deducted from the main source file name. -This attribute has no effect if its value is the empty string. - -@item Executable_Suffix -This is a simple attribute whose value is the suffix to be added to -the executables that don't have an attribute Executable specified. -@end table - -@subsection package Gnatls - -@noindent -The attributes of package @code{Gnatls} specify the tool options to be used -when invoking the library browser @command{gnatls}. -The following attributes apply to package @code{Gnatls}: - -@table @code -@item Switches -This is a single attribute with a string list value. Each nonempty string -in the list is an option when invoking @code{gnatls}. -@end table - -@subsection package Binder - -@noindent -The attributes of package @code{Binder} specify the options to be used -when invoking the binder in the construction of an executable. -The following attributes apply to package @code{Binder}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when binding a main -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when binding the named main file. If a main file -is not specified in the Switches attribute, it is bound with the -options specified by Default_Switches of its language, if defined. -@end table - -@subsection package Linker - -@noindent -The attributes of package @code{Linker} specify the options to be used when -invoking the linker in the construction of an executable. -The following attributes apply to package @code{Linker}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when linking a main -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when linking the named main file. If a main file -is not specified in the Switches attribute, it is linked with the -options specified by Default_Switches of its language, if defined. - -@item Linker_Options -This is a string list attribute. Its value specifies additional options that -be given to the linker when linking an executable. This attribute is not -used in the main project, only in projects imported directly or indirectly. - -@end table - -@subsection package Cross_Reference - -@noindent -The attributes of package @code{Cross_Reference} specify the tool options -to be used -when invoking the library tool @command{gnatxref}. -The following attributes apply to package @code{Cross_Reference}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatxref} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatxref} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatxref} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Finder - -@noindent -The attributes of package @code{Finder} specify the tool options to be used -when invoking the search tool @command{gnatfind}. -The following attributes apply to package @code{Finder}: - -@table @code -@item Default_Switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatfind} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatfind} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatfind} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Check - -@noindent -The attributes of package @code{Check} -specify the checking rule options to be used -when invoking the checking tool @command{gnatcheck}. -The following attributes apply to package @code{Check}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatcheck} on a source -written in that language. The first string in the range should always be -@code{"-rules"} to specify that all the other options belong to the -@code{-rules} section of the parameters of @command{gnatcheck} call. - -@end table - -@subsection package Pretty_Printer - -@noindent -The attributes of package @code{Pretty_Printer} -specify the tool options to be used -when invoking the formatting tool @command{gnatpp}. -The following attributes apply to package @code{Pretty_Printer}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatpp} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatpp} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatpp} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package gnatstub - -@noindent -The attributes of package @code{gnatstub} -specify the tool options to be used -when invoking the tool @command{gnatstub}. -The following attributes apply to package @code{gnatstub}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatstub} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatstub} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatpp} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Eliminate - -@noindent -The attributes of package @code{Eliminate} -specify the tool options to be used -when invoking the tool @command{gnatelim}. -The following attributes apply to package @code{Eliminate}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatelim} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatelim} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatelim} will -be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package Metrics - -@noindent -The attributes of package @code{Metrics} -specify the tool options to be used -when invoking the tool @command{gnatmetric}. -The following attributes apply to package @code{Metrics}: - -@table @code -@item Default_switches -This is an associative array attribute. Its -domain is a set of language names. Its range is a string list that -specifies options to be used when calling @command{gnatmetric} on a source -written in that language, for which no file-specific switches have been -specified. - -@item Switches -This is an associative array attribute. Its domain is -a set of file names. Its range is a string list that specifies -options to be used when calling @command{gnatmetric} on the named main source. -If a source is not specified in the Switches attribute, @command{gnatmetric} -will be called with the options specified by Default_Switches of its language, -if defined. -@end table - -@subsection package IDE - -@noindent -The attributes of package @code{IDE} specify the options to be used when using -an Integrated Development Environment such as @command{GPS}. - -@table @code -@item Remote_Host -This is a simple attribute. Its value is a string that designates the remote -host in a cross-compilation environment, to be used for remote compilation and -debugging. This field should not be specified when running on the local -machine. - -@item Program_Host -This is a simple attribute. Its value is a string that specifies the -name of IP address of the embedded target in a cross-compilation environment, -on which the program should execute. - -@item Communication_Protocol -This is a simple string attribute. Its value is the name of the protocol -to use to communicate with the target in a cross-compilation environment, -e.g.@: @code{"wtx"} or @code{"vxworks"}. - -@item Compiler_Command -This is an associative array attribute, whose domain is a language name. Its -value is string that denotes the command to be used to invoke the compiler. -The value of @code{Compiler_Command ("Ada")} is expected to be compatible with -gnatmake, in particular in the handling of switches. - -@item Debugger_Command -This is simple attribute, Its value is a string that specifies the name of -the debugger to be used, such as gdb, powerpc-wrs-vxworks-gdb or gdb-4. - -@item Default_Switches -This is an associative array attribute. Its indexes are the name of the -external tools that the GNAT Programming System (GPS) is supporting. Its -value is a list of switches to use when invoking that tool. - -@item Gnatlist -This is a simple attribute. Its value is a string that specifies the name -of the @command{gnatls} utility to be used to retrieve information about the -predefined path; e.g., @code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. - -@item VCS_Kind -This is a simple attribute. Its value is a string used to specify the -Version Control System (VCS) to be used for this project, e.g.@: CVS, RCS -ClearCase or Perforce. - -@item VCS_File_Check -This is a simple attribute. Its value is a string that specifies the -command used by the VCS to check the validity of a file, either -when the user explicitly asks for a check, or as a sanity check before -doing the check-in. - -@item VCS_Log_Check -This is a simple attribute. Its value is a string that specifies -the command used by the VCS to check the validity of a log file. - -@item VCS_Repository_Root -The VCS repository root path. This is used to create tags or branches -of the repository. For subversion the value should be the @code{URL} -as specified to check-out the working copy of the repository. - -@item VCS_Patch_Root -The local root directory to use for building patch file. All patch chunks -will be relative to this path. The root project directory is used if -this value is not defined. - -@end table - -@node Package Renamings -@section Package Renamings - -@noindent -A package can be defined by a renaming declaration. The new package renames -a package declared in a different project file, and has the same attributes -as the package it renames. -Syntax: -@smallexample -package_renaming ::== - @b{package} package_identifier @b{renames} - <project_>simple_name.package_identifier ; -@end smallexample - -@noindent -The package_identifier of the renamed package must be the same as the -package_identifier. The project whose name is the prefix of the renamed -package must contain a package declaration with this name. This project -must appear in the context_clause of the enclosing project declaration, -or be the parent project of the enclosing child project. - -@node Projects -@section Projects - -@noindent -A project file specifies a set of rules for constructing a software system. -A project file can be self-contained, or depend on other project files. -Dependencies are expressed through a context clause that names other projects. - -Syntax: - -@smallexample -project ::= - context_clause project_declaration - -project_declaration ::= - simple_project_declaration | project_extension - -simple_project_declaration ::= - @b{project} <project_>simple_name @b{is} - @{declarative_item@} - @b{end} <project_>simple_name; - -context_clause ::= - @{with_clause@} - -with_clause ::= - [@b{limited}] @b{with} path_name @{ , path_name @} ; - -path_name ::= - string_literal -@end smallexample - -@noindent -A path name denotes a project file. A path name can be absolute or relative. -An absolute path name includes a sequence of directories, in the syntax of -the host operating system, that identifies uniquely the project file in the -file system. A relative path name identifies the project file, relative -to the directory that contains the current project, or relative to a -directory listed in the environment variable ADA_PROJECT_PATH. -Path names are case sensitive if file names in the host operating system -are case sensitive. - -The syntax of the environment variable ADA_PROJECT_PATH is a list of -directory names separated by colons (semicolons on Windows). - -A given project name can appear only once in a context_clause. - -It is illegal for a project imported by a context clause to refer, directly -or indirectly, to the project in which this context clause appears (the -dependency graph cannot contain cycles), except when one of the with_clause -in the cycle is a @code{limited with}. - -@node Project Extensions -@section Project Extensions - -@noindent -A project extension introduces a new project, which inherits the declarations -of another project. -Syntax: -@smallexample - -project_extension ::= - @b{project} <project_>simple_name @b{extends} path_name @b{is} - @{declarative_item@} - @b{end} <project_>simple_name; -@end smallexample - -@noindent -The project extension declares a child project. The child project inherits -all the declarations and all the files of the parent project, These inherited -declaration can be overridden in the child project, by means of suitable -declarations. - -@node Project File Elaboration -@section Project File Elaboration - -@noindent -A project file is processed as part of the invocation of a gnat tool that -uses the project option. Elaboration of the process file consists in the -sequential elaboration of all its declarations. The computed values of -attributes and variables in the project are then used to establish the -environment in which the gnat tool will execute. - @node Obsolescent Features @chapter Obsolescent Features diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 7ea24549e46..e18baef53d5 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -176,6 +176,7 @@ AdaCore@* * Configuration Pragmas:: * Handling Arbitrary File Naming Conventions Using gnatname:: * GNAT Project Manager:: +* Tools Supporting Project Files:: * The Cross-Referencing Tools gnatxref and gnatfind:: * The GNAT Pretty-Printer gnatpp:: * The GNAT Metric Tool gnatmetric:: @@ -376,26 +377,6 @@ Handling Arbitrary File Naming Conventions Using gnatname * Switches for gnatname:: * Examples of gnatname Usage:: -GNAT Project Manager - -* Introduction:: -* Examples of Project Files:: -* Project File Syntax:: -* Objects and Sources in Project Files:: -* Importing Projects:: -* Project Extension:: -* Project Hierarchy Extension:: -* External References in Project Files:: -* Packages in Project Files:: -* Variables from Imported Projects:: -* Naming Schemes:: -* Library Projects:: -* Stand-alone Library Projects:: -* Switches Related to Project Files:: -* Tools Supporting Project Files:: -* An Extended Example:: -* Project File Complete Syntax:: - The Cross-Referencing Tools gnatxref and gnatfind * Switches for gnatxref:: @@ -531,6 +512,7 @@ Running and Debugging Ada Programs * Ada Exceptions:: * Ada Tasks:: * Debugging Generic Units:: +* Remote Debugging using gdbserver:: * GNAT Abnormal Termination or Failure to Terminate:: * Naming Conventions for GNAT Source Files:: * Getting Internal Debugging Information:: @@ -4078,6 +4060,17 @@ Enforce Ada 95 restrictions. @cindex @option{-gnat05} (@command{gcc}) Allow full Ada 2005 features. +@item -gnat2005 +@cindex @option{-gnat2005} (@command{gcc}) +Allow full Ada 2005 features (same as @option{-gnat05} + +@item -gnat12 +@cindex @option{-gnat12} (@command{gcc}) + +@item -gnat2012 +@cindex @option{-gnat2012} (@command{gcc}) +Allow full Ada 2012 features (same as @option{-gnat12} + @item -gnata @cindex @option{-gnata} (@command{gcc}) Assertions enabled. @code{Pragma Assert} and @code{pragma Debug} to be @@ -4200,7 +4193,7 @@ Note that @option{^-gnatg^/GNAT_INTERNAL^} implies @option{^-gnatwae^/WARNINGS=ALL,ERRORS^} and @option{^-gnatyg^/STYLE_CHECKS=GNAT^} so that all standard warnings and all standard style options are turned on. -All warnings and style error messages are treated as errors. +All warnings and style messages are treated as errors. @ifclear vms @item -gnatG=nn @@ -4294,7 +4287,12 @@ controlled by this switch (division by zero checking is on by default). @item -gnatp @cindex @option{-gnatp} (@command{gcc}) -Suppress all checks. See @ref{Run-Time Checks} for details. +Suppress all checks. See @ref{Run-Time Checks} for details. This switch +has no effect if cancelled by a subsequent @option{-gnat-p} switch. + +@item -gnat-p +@cindex @option{-gnat-p} (@command{gcc}) +Cancel effect of previous @option{-gnatp} switch. @item -gnatP @cindex @option{-gnatP} (@command{gcc}) @@ -4372,6 +4370,10 @@ Wide character encoding method @cindex @option{-gnatx} (@command{gcc}) Suppress generation of cross-reference information. +@item -gnatX +@cindex @option{-gnatX} (@command{gcc}) +Enable GNAT implementation extensions and latest Ada version. + @item ^-gnaty^/STYLE_CHECKS=(option,option@dots{})^ @cindex @option{^-gnaty^/STYLE_CHECKS^} (@command{gcc}) Enable built-in style checks (@pxref{Style Checking}). @@ -4591,6 +4593,9 @@ The switches @option{-gnatzc} and @option{-gnatzr} may not be combined with any other switches, and only one of them may appear in the command line. +@item +The switch @option{-gnat-p} may not be combined with any other switch. + @ifclear vms @item Once a ``y'' appears in the string (that is a use of the @option{-gnaty} @@ -5204,12 +5209,14 @@ This switch suppresses warnings for implicit dereferences in indexed components, slices, and selected components. @item -gnatwe -@emph{Treat warnings as errors.} +@emph{Treat warnings and style checks as errors.} @cindex @option{-gnatwe} (@command{gcc}) @cindex Warnings, treat as error -This switch causes warning messages to be treated as errors. +This switch causes warning messages and style check messages to be +treated as errors. The warning string still appears, but the warning messages are counted -as errors, and prevent the generation of an object file. +as errors, and prevent the generation of an object file. Note that this +is the only -gnatw switch that affects the handling of style check messages. @item -gnatw.e @emph{Activate every optional warning} @@ -5572,7 +5579,8 @@ This switch completely suppresses the output of all warning messages from the GNAT front end. Note that it does not suppress warnings from the @command{gcc} back end. To suppress these back end warnings as well, use the switch @option{-w} -in addition to @option{-gnatws}. +in addition to @option{-gnatws}. Also this switch has no effect on the +handling of style check messages. @item -gnatwt @emph{Activate warnings for tracking of deleted conditional code.} @@ -6131,8 +6139,10 @@ causes the compiler to enforce specified style rules. A limited set of style rules has been used in writing the GNAT sources themselves. This switch allows user programs to activate all or some of these checks. If the source program fails a -specified style check, an appropriate warning message is given, preceded by -the character sequence ``(style)''. +specified style check, an appropriate message is given, preceded by +the character sequence ``(style)''. This message does not prevent +successful compilation (unless the @option{-gnatwe} switch is used). + @ifset vms @code{(option,option,@dots{})} is a sequence of keywords @end ifset @@ -6622,6 +6632,16 @@ year). The compiler will generate code based on the assumption that the condition being checked is true, which can result in disaster if that assumption is wrong. +The @option{-gnatp} switch has no effect if a subsequent +@option{-gnat-p} switch appears. + +@item -gnat-p +@cindex @option{-gnat-p} (@command{gcc}) +@cindex Suppressing checks +@cindex Checks, suppressing +@findex Suppress +This switch cancels the effect of a previous @option{gnatp} switch. + @item -gnato @cindex @option{-gnato} (@command{gcc}) @cindex Overflow checks @@ -6895,27 +6915,60 @@ uses of the new Ada 2005 features will cause error messages or warnings. This switch also can be used to cancel the effect of a previous -@option{-gnat83} or @option{-gnat05} switch earlier in the command line. +@option{-gnat83}, @option{-gnat05/2005}, or @option{-gnat12/2012} +switch earlier in the command line. -@item -gnat05 (Ada 2005 mode) +@item -gnat05 or -gnat2005 (Ada 2005 mode) @cindex @option{-gnat05} (@command{gcc}) +@cindex @option{-gnat2005} (@command{gcc}) @cindex Ada 2005 mode @noindent This switch directs the compiler to implement the Ada 2005 version of the -language. +language, as documented in the official Ada standards document. Since Ada 2005 is almost completely upwards compatible with Ada 95 (and thus also with Ada 83), Ada 83 and Ada 95 programs may generally be compiled using this switch (see the description of the @option{-gnat83} and @option{-gnat95} switches for further information). +Note that even though Ada 2005 is the current official version of the +language, GNAT still compiles in Ada 95 mode by default, so if you are +using Ada 2005 features in your program, you must use this switch (or +the equivalent Ada_05 or Ada_2005 configuration pragmas). + +@item -gnat12 or -gnat2012 (Ada 2012 mode) +@cindex @option{-gnat12} (@command{gcc}) +@cindex @option{-gnat2012} (@command{gcc}) +@cindex Ada 2012 mode + +@noindent +This switch directs the compiler to implement the Ada 2012 version of the +language. +Since Ada 2012 is almost completely upwards +compatible with Ada 2005 (and thus also with Ada 83, and Ada 95), +Ada 83 and Ada 95 programs +may generally be compiled using this switch (see the description of the +@option{-gnat83}, @option{-gnat95}, and @option{-gnat05/2005} switches +for further information). + For information about the approved ``Ada Issues'' that have been incorporated -into Ada 2005, see @url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs}. -Included with GNAT releases is a file @file{features-ada0y} that describes -the set of implemented Ada 2005 features. -@end table +into Ada 2012, see @url{http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs}. +Included with GNAT releases is a file @file{features-ada12} that describes +the set of implemented Ada 2012 features. + +@item -gnatX (Enable GNAT Extensions) +@cindex @option{-gnatX} (@command{gcc}) +@cindex Ada language extensions +@cindex GNAT extensions +@noindent +This switch directs the compiler to implement the latest version of the +language (currently Ada 2012) and also to enable certain GNAT implementation +extensions that are not part of any Ada standard. For a full list of these +extensions, see the GNAT reference manual. + +@end table @node Character Set Control @subsection Character Set Control @@ -7909,7 +7962,7 @@ $ gnatbind @r{[}@var{switches}@r{]} @var{mainprog}@r{[}.ali@r{]} @r{[}@var{switc @noindent where @file{@var{mainprog}.adb} is the Ada file containing the main program -unit body. If no switches are specified, @code{gnatbind} constructs an Ada +unit body. @code{gnatbind} constructs an Ada package in two files whose names are @file{b~@var{mainprog}.ads}, and @file{b~@var{mainprog}.adb}. For example, if given the @@ -7980,14 +8033,6 @@ the generated main program. It can also be debugged just like any other Ada code provided the @option{^-g^/DEBUG^} switch is used for @command{gnatbind} and @command{gnatlink}. -However for some purposes it may be convenient to generate the main -program in C rather than Ada. This may for example be helpful when you -are generating a mixed language program with the main program in C. The -GNAT compiler itself is an example. -The use of the @option{^-C^/BIND_FILE=C^} switch -for both @code{gnatbind} and @command{gnatlink} will cause the program to -be generated in C (and compiled using the gnu C compiler). - @node Switches for gnatbind @section Switches for @command{gnatbind} @@ -8031,9 +8076,9 @@ Specify directory to be searched for ALI files. @cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatbind}) Specify directory to be searched for source file. -@item ^-A^/BIND_FILE=ADA^ -@cindex @option{^-A^/BIND_FILE=ADA^} (@command{gnatbind}) -Generate binder program in Ada (default) +@item ^-A^/ALI_LIST^@r{[=}@var{filename}@r{]} +@cindex @option{^-A^/ALI_LIST^} (@command{gnatbind}) +Output ALI list (to standard output or to the named file). @item ^-b^/REPORT_ERRORS=BRIEF^ @cindex @option{^-b^/REPORT_ERRORS=BRIEF^} (@command{gnatbind}) @@ -8043,10 +8088,6 @@ Generate brief messages to @file{stderr} even if verbose mode set. @cindex @option{^-c^/NOOUTPUT^} (@command{gnatbind}) Check only, no generation of binder output file. -@item ^-C^/BIND_FILE=C^ -@cindex @option{^-C^/BIND_FILE=C^} (@command{gnatbind}) -Generate binder program in C - @item ^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} @cindex @option{^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]}} (@command{gnatbind}) This switch can be used to change the default task stack size value @@ -8191,9 +8232,9 @@ Name the output file @var{file} (default is @file{b~@var{xxx}.adb}). Note that if this option is used, then linking must be done manually, gnatlink cannot be used. -@item ^-O^/OBJECT_LIST^ +@item ^-O^/OBJECT_LIST^@r{[=}@var{filename}@r{]} @cindex @option{^-O^/OBJECT_LIST^} (@command{gnatbind}) -Output object list. +Output object list (to standard output or to the named file). @item ^-p^/PESSIMISTIC_ELABORATION^ @cindex @option{^-p^/PESSIMISTIC_ELABORATION^} (@command{gnatbind}) @@ -8492,24 +8533,11 @@ generated by the binder. @table @option @c !sort! -@item ^-A^/BIND_FILE=ADA^ -@cindex @option{^-A^/BIND_FILE=ADA^} (@code{gnatbind}) -Generate binder program in Ada (default). The binder program is named -@file{b~@var{mainprog}.adb} by default. This can be changed with -@option{^-o^/OUTPUT^} @code{gnatbind} option. - @item ^-c^/NOOUTPUT^ @cindex @option{^-c^/NOOUTPUT^} (@code{gnatbind}) Check only. Do not generate the binder output file. In this mode the binder performs all error checks but does not generate an output file. -@item ^-C^/BIND_FILE=C^ -@cindex @option{^-C^/BIND_FILE=C^} (@code{gnatbind}) -Generate binder program in C. The binder program is named -@file{b_@var{mainprog}.c}. -This can be changed with @option{^-o^/OUTPUT^} @code{gnatbind} -option. - @item ^-e^/ELABORATION_DEPENDENCIES^ @cindex @option{^-e^/ELABORATION_DEPENDENCIES^} (@code{gnatbind}) Output complete list of elaboration-order dependencies, showing the @@ -8544,8 +8572,7 @@ directory names for the run-time units depend on the system configuration. @cindex @option{^-o^/OUTPUT^} (@code{gnatbind}) Set name of output file to @var{file} instead of the normal @file{b~@var{mainprog}.adb} default. Note that @var{file} denote the Ada -binder generated body filename. In C mode you would normally give -@var{file} an extension of @file{.c} because it will be a C source program. +binder generated body filename. Note that if this option is used, then linking must be done manually. It is not possible to use gnatlink in this case, since it cannot locate the binder file. @@ -8619,9 +8646,7 @@ more quite separate groups of Ada units. The binder takes the name of its output file from the last specified ALI file, unless overridden by the use of the @option{^-o file^/OUTPUT=file^}. @cindex @option{^-o^/OUTPUT^} (@command{gnatbind}) -The output is an Ada unit in source form that can -be compiled with GNAT unless the -C switch is used in which case the -output is a C source file, which must be compiled using the C compiler. +The output is an Ada unit in source form that can be compiled with GNAT. This compilation occurs automatically as part of the @command{gnatlink} processing. @@ -8818,39 +8843,8 @@ The main program @code{Hello} (source program in @file{hello.adb}) is bound using the standard switch settings. The generated main program is @file{mainprog.adb} with the associated spec in @file{mainprog.ads}. Note that you must specify the body here not the -spec, in the case where the output is in Ada. Note that if this option -is used, then linking must be done manually, since gnatlink will not -be able to find the generated file. - -@ifclear vms -@item gnatbind main -C -o mainprog.c -x -@end ifclear -@ifset vms -@item gnatbind MAIN.ALI /BIND_FILE=C /OUTPUT=Mainprog.C /READ_SOURCES=NONE -@end ifset -The main program @code{Main} (source program in -@file{main.adb}) is bound, excluding source files from the -consistency checking, generating -the file @file{mainprog.c}. - -@ifclear vms -@item gnatbind -x main_program -C -o mainprog.c -This command is exactly the same as the previous example. Switches may -appear anywhere in the command line, and single letter switches may be -combined into a single switch. -@end ifclear - -@ifclear vms -@item gnatbind -n math dbase -C -o ada-control.c -@end ifclear -@ifset vms -@item gnatbind /NOMAIN math dbase /BIND_FILE=C /OUTPUT=ada-control.c -@end ifset -The main program is in a language other than Ada, but calls to -subprograms in packages @code{Math} and @code{Dbase} appear. This call -to @code{gnatbind} generates the file @file{ada-control.c} containing -the @code{adainit} and @code{adafinal} routines to be called before and -after accessing the Ada units. +spec. Note that if this option is used, then linking must be done manually, +since gnatlink will not be able to find the generated file. @end table @c ------------------------------------ @@ -8969,17 +8963,6 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^-A^/BIND_FILE=ADA^ -@cindex @option{^-A^/BIND_FILE=ADA^} (@command{gnatlink}) -The binder has generated code in Ada. This is the default. - -@item ^-C^/BIND_FILE=C^ -@cindex @option{^-C^/BIND_FILE=C^} (@command{gnatlink}) -If instead of generating a file in Ada, the binder has generated one in -C, then the linker needs to know about it. Use this switch to signal -to @command{gnatlink} that the binder has generated C code rather than -Ada code. - @item ^-f^/FORCE_OBJECT_FILE_LIST^ @cindex Command line length @cindex @option{^-f^/FORCE_OBJECT_FILE_LIST^} (@command{gnatlink}) @@ -9258,6 +9241,15 @@ itself must not include any embedded spaces. @end ifclear +@item ^--subdirs^/SUBDIRS^=subdir +Actual object directory of each project file is the subdirectory subdir of the +object directory specified or defauted in the project file. + +@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +By default, shared library projects are not allowed to import static library +projects. When this switch is used on the command line, this restriction is +relaxed. + @item ^-a^/ALL_FILES^ @cindex @option{^-a^/ALL_FILES^} (@command{gnatmake}) Consider all files in the make process, even the GNAT internal system @@ -10783,6 +10775,10 @@ is named @file{gnatelim.log} and is located in the current directory. @cindex @option{^-log^/LOGFILE^} (@command{gnatelim}) Duplicate all the output sent to @file{stderr} into a specified log file. +@cindex @option{^--no-elim-dispatch^/NO_DISPATCH^} (@command{gnatelim}) +@item ^--no-elim-dispatch^/NO_DISPATCH^ +Do not generate pragmas for dispatching operations. + @cindex @option{^-o^/OUTPUT^} (@command{gnatelim}) @item ^-o^/OUTPUT^=@var{report_file} Put @command{gnatelim} output into a specified file. If this file already exists, @@ -11405,6 +11401,8 @@ recognized by GNAT: Ada_95 Ada_05 Ada_2005 + Ada_12 + Ada_2012 Assertion_Policy Assume_No_Invalid_Values C_Pass_By_Copy @@ -11448,6 +11446,7 @@ recognized by GNAT: Restrictions Restrictions_Warnings Reviewable + Short_Circuit_And_Or Source_File_Name Source_File_Name_Project Style_Checks @@ -11595,7 +11594,8 @@ regular files. @noindent One or several Naming Patterns may be given as arguments to @code{gnatname}. -Each Naming Pattern is enclosed between double quotes. +Each Naming Pattern is enclosed between double quotes (or single +quotes on Windows). A Naming Pattern is a regular expression similar to the wildcard patterns used in file names by the Unix shells or the DOS prompt. @@ -11794,3602 +11794,58 @@ are used in this example. @c ***************************************** @c * G N A T P r o j e c t M a n a g e r * @c ***************************************** -@node GNAT Project Manager -@chapter GNAT Project Manager - -@menu -* Introduction:: -* Examples of Project Files:: -* Project File Syntax:: -* Objects and Sources in Project Files:: -* Importing Projects:: -* Project Extension:: -* Project Hierarchy Extension:: -* External References in Project Files:: -* Packages in Project Files:: -* Variables from Imported Projects:: -* Naming Schemes:: -* Library Projects:: -* Stand-alone Library Projects:: -* Switches Related to Project Files:: -* Tools Supporting Project Files:: -* An Extended Example:: -* Project File Complete Syntax:: -@end menu - -@c **************** -@c * Introduction * -@c **************** - -@node Introduction -@section Introduction - -@noindent -This chapter describes GNAT's @emph{Project Manager}, a facility that allows -you to manage complex builds involving a number of source files, directories, -and compilation options for different system configurations. In particular, -project files allow you to specify: -@itemize @bullet -@item -The directory or set of directories containing the source files, and/or the -names of the specific source files themselves -@item -The directory in which the compiler's output -(@file{ALI} files, object files, tree files) is to be placed -@item -The directory in which the executable programs is to be placed -@item -^Switch^Switch^ settings for any of the project-enabled tools -(@command{gnatmake}, compiler, binder, linker, @code{gnatls}, @code{gnatxref}, -@code{gnatfind}); you can apply these settings either globally or to individual -compilation units. -@item -The source files containing the main subprogram(s) to be built -@item -The source programming language(s) (currently Ada and/or C) -@item -Source file naming conventions; you can specify these either globally or for -individual compilation units -@end itemize - -@menu -* Project Files:: -@end menu - -@node Project Files -@subsection Project Files - -@noindent -Project files are written in a syntax close to that of Ada, using familiar -notions such as packages, context clauses, declarations, default values, -assignments, and inheritance. Finally, project files can be built -hierarchically from other project files, simplifying complex system -integration and project reuse. - -A @dfn{project} is a specific set of values for various compilation properties. -The settings for a given project are described by means of -a @dfn{project file}, which is a text file written in an Ada-like syntax. -Property values in project files are either strings or lists of strings. -Properties that are not explicitly set receive default values. A project -file may interrogate the values of @dfn{external variables} (user-defined -command-line switches or environment variables), and it may specify property -settings conditionally, based on the value of such variables. - -In simple cases, a project's source files depend only on other source files -in the same project, or on the predefined libraries. (@emph{Dependence} is -used in -the Ada technical sense; as in one Ada unit @code{with}ing another.) However, -the Project Manager also allows more sophisticated arrangements, -where the source files in one project depend on source files in other -projects: -@itemize @bullet -@item -One project can @emph{import} other projects containing needed source files. -@item -You can organize GNAT projects in a hierarchy: a @emph{child} project -can extend a @emph{parent} project, inheriting the parent's source files and -optionally overriding any of them with alternative versions -@end itemize - -@noindent -More generally, the Project Manager lets you structure large development -efforts into hierarchical subsystems, where build decisions are delegated -to the subsystem level, and thus different compilation environments -(^switch^switch^ settings) used for different subsystems. - -The Project Manager is invoked through the -@option{^-P^/PROJECT_FILE=^@emph{projectfile}} -switch to @command{gnatmake} or to the @command{^gnat^GNAT^} front driver. -@ifclear vms -There may be zero, one or more spaces between @option{-P} and -@option{@emph{projectfile}}. -@end ifclear -If you want to define (on the command line) an external variable that is -queried by the project file, you must use the -@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. -The Project Manager parses and interprets the project file, and drives the -invoked tool based on the project settings. - -The Project Manager supports a wide range of development strategies, -for systems of all sizes. Here are some typical practices that are -easily handled: -@itemize @bullet -@item -Using a common set of source files, but generating object files in different -directories via different ^switch^switch^ settings -@item -Using a mostly-shared set of source files, but with different versions of -some unit or units -@end itemize - -@noindent -The destination of an executable can be controlled inside a project file -using the @option{^-o^-o^} -^switch^switch^. -In the absence of such a ^switch^switch^ either inside -the project file or on the command line, any executable files generated by -@command{gnatmake} are placed in the directory @code{Exec_Dir} specified -in the project file. If no @code{Exec_Dir} is specified, they will be placed -in the object directory of the project. - -You can use project files to achieve some of the effects of a source -versioning system (for example, defining separate projects for -the different sets of sources that comprise different releases) but the -Project Manager is independent of any source configuration management tools -that might be used by the developers. - -The next section introduces the main features of GNAT's project facility -through a sequence of examples; subsequent sections will present the syntax -and semantics in more detail. A more formal description of the project -facility appears in @ref{Project File Reference,,, gnat_rm, GNAT -Reference Manual}. - -@c ***************************** -@c * Examples of Project Files * -@c ***************************** - -@node Examples of Project Files -@section Examples of Project Files -@noindent -This section illustrates some of the typical uses of project files and -explains their basic structure and behavior. - -@menu -* Common Sources with Different ^Switches^Switches^ and Directories:: -* Using External Variables:: -* Importing Other Projects:: -* Extending a Project:: -@end menu - -@node Common Sources with Different ^Switches^Switches^ and Directories -@subsection Common Sources with Different ^Switches^Switches^ and Directories - -@menu -* Source Files:: -* Specifying the Object Directory:: -* Specifying the Exec Directory:: -* Project File Packages:: -* Specifying ^Switch^Switch^ Settings:: -* Main Subprograms:: -* Executable File Names:: -* Source File Naming Conventions:: -* Source Language(s):: -@end menu - -@noindent -Suppose that the Ada source files @file{pack.ads}, @file{pack.adb}, and -@file{proc.adb} are in the @file{/common} directory. The file -@file{proc.adb} contains an Ada main subprogram @code{Proc} that @code{with}s -package @code{Pack}. We want to compile these source files under two sets -of ^switches^switches^: -@itemize @bullet -@item -When debugging, we want to pass the @option{-g} switch to @command{gnatmake}, -and the @option{^-gnata^-gnata^}, -@option{^-gnato^-gnato^}, -and @option{^-gnatE^-gnatE^} switches to the -compiler; the compiler's output is to appear in @file{/common/debug} -@item -When preparing a release version, we want to pass the @option{^-O2^O2^} switch -to the compiler; the compiler's output is to appear in @file{/common/release} -@end itemize - -@noindent -The GNAT project files shown below, respectively @file{debug.gpr} and -@file{release.gpr} in the @file{/common} directory, achieve these effects. - -Schematically: -@smallexample -@group -^/common^[COMMON]^ - debug.gpr - release.gpr - pack.ads - pack.adb - proc.adb -@end group -@group -^/common/debug^[COMMON.DEBUG]^ - proc.ali, proc.o - pack.ali, pack.o -@end group -@group -^/common/release^[COMMON.RELEASE]^ - proc.ali, proc.o - pack.ali, pack.o -@end group -@end smallexample -Here are the corresponding project files: - -@smallexample @c projectfile -@group -project Debug is - for Object_Dir use "debug"; - for Main use ("proc"); - - package Builder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for Executable ("proc.adb") use "proc1"; - end Builder; -@end group - -@group - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("-fstack-check", - "^-gnata^-gnata^", - "^-gnato^-gnato^", - "^-gnatE^-gnatE^"); - end Compiler; -end Debug; -@end group -@end smallexample - -@smallexample @c projectfile -@group -project Release is - for Object_Dir use "release"; - for Exec_Dir use "."; - for Main use ("proc"); - - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-O2^-O2^"); - end Compiler; -end Release; -@end group -@end smallexample - -@noindent -The name of the project defined by @file{debug.gpr} is @code{"Debug"} (case -insensitive), and analogously the project defined by @file{release.gpr} is -@code{"Release"}. For consistency the file should have the same name as the -project, and the project file's extension should be @code{"gpr"}. These -conventions are not required, but a warning is issued if they are not followed. - -If the current directory is @file{^/temp^[TEMP]^}, then the command -@smallexample -gnatmake ^-P/common/debug.gpr^/PROJECT_FILE=[COMMON]DEBUG^ -@end smallexample - -@noindent -generates object and ALI files in @file{^/common/debug^[COMMON.DEBUG]^}, -as well as the @code{^proc1^PROC1.EXE^} executable, -using the ^switch^switch^ settings defined in the project file. - -Likewise, the command -@smallexample -gnatmake ^-P/common/release.gpr^/PROJECT_FILE=[COMMON]RELEASE^ -@end smallexample - -@noindent -generates object and ALI files in @file{^/common/release^[COMMON.RELEASE]^}, -and the @code{^proc^PROC.EXE^} -executable in @file{^/common^[COMMON]^}, -using the ^switch^switch^ settings from the project file. - -@node Source Files -@unnumberedsubsubsec Source Files - -@noindent -If a project file does not explicitly specify a set of source directories or -a set of source files, then by default the project's source files are the -Ada source files in the project file directory. Thus @file{pack.ads}, -@file{pack.adb}, and @file{proc.adb} are the source files for both projects. - -@node Specifying the Object Directory -@unnumberedsubsubsec Specifying the Object Directory - -@noindent -Several project properties are modeled by Ada-style @emph{attributes}; -a property is defined by supplying the equivalent of an Ada attribute -definition clause in the project file. -A project's object directory is another such a property; the corresponding -attribute is @code{Object_Dir}, and its value is also a string expression, -specified either as absolute or relative. In the later case, -it is relative to the project file directory. Thus the compiler's -output is directed to @file{^/common/debug^[COMMON.DEBUG]^} -(for the @code{Debug} project) -and to @file{^/common/release^[COMMON.RELEASE]^} -(for the @code{Release} project). -If @code{Object_Dir} is not specified, then the default is the project file -directory itself. - -@node Specifying the Exec Directory -@unnumberedsubsubsec Specifying the Exec Directory - -@noindent -A project's exec directory is another property; the corresponding -attribute is @code{Exec_Dir}, and its value is also a string expression, -either specified as relative or absolute. If @code{Exec_Dir} is not specified, -then the default is the object directory (which may also be the project file -directory if attribute @code{Object_Dir} is not specified). Thus the executable -is placed in @file{^/common/debug^[COMMON.DEBUG]^} -for the @code{Debug} project (attribute @code{Exec_Dir} not specified) -and in @file{^/common^[COMMON]^} for the @code{Release} project. - -@node Project File Packages -@unnumberedsubsubsec Project File Packages - -@noindent -A GNAT tool that is integrated with the Project Manager is modeled by a -corresponding package in the project file. In the example above, -The @code{Debug} project defines the packages @code{Builder} -(for @command{gnatmake}) and @code{Compiler}; -the @code{Release} project defines only the @code{Compiler} package. - -The Ada-like package syntax is not to be taken literally. Although packages in -project files bear a surface resemblance to packages in Ada source code, the -notation is simply a way to convey a grouping of properties for a named -entity. Indeed, the package names permitted in project files are restricted -to a predefined set, corresponding to the project-aware tools, and the contents -of packages are limited to a small set of constructs. -The packages in the example above contain attribute definitions. - -@node Specifying ^Switch^Switch^ Settings -@unnumberedsubsubsec Specifying ^Switch^Switch^ Settings - -@noindent -^Switch^Switch^ settings for a project-aware tool can be specified through -attributes in the package that corresponds to the tool. -The example above illustrates one of the relevant attributes, -@code{^Default_Switches^Default_Switches^}, which is defined in packages -in both project files. -Unlike simple attributes like @code{Source_Dirs}, -@code{^Default_Switches^Default_Switches^} is -known as an @emph{associative array}. When you define this attribute, you must -supply an ``index'' (a literal string), and the effect of the attribute -definition is to set the value of the array at the specified index. -For the @code{^Default_Switches^Default_Switches^} attribute, -the index is a programming language (in our case, Ada), -and the value specified (after @code{use}) must be a list -of string expressions. - -The attributes permitted in project files are restricted to a predefined set. -Some may appear at project level, others in packages. -For any attribute that is an associative array, the index must always be a -literal string, but the restrictions on this string (e.g., a file name or a -language name) depend on the individual attribute. -Also depending on the attribute, its specified value will need to be either a -string or a string list. - -In the @code{Debug} project, we set the switches for two tools, -@command{gnatmake} and the compiler, and thus we include the two corresponding -packages; each package defines the @code{^Default_Switches^Default_Switches^} -attribute with index @code{"Ada"}. -Note that the package corresponding to -@command{gnatmake} is named @code{Builder}. The @code{Release} project is -similar, but only includes the @code{Compiler} package. - -In project @code{Debug} above, the ^switches^switches^ starting with -@option{-gnat} that are specified in package @code{Compiler} -could have been placed in package @code{Builder}, since @command{gnatmake} -transmits all such ^switches^switches^ to the compiler. - -@node Main Subprograms -@unnumberedsubsubsec Main Subprograms - -@noindent -One of the specifiable properties of a project is a list of files that contain -main subprograms. This property is captured in the @code{Main} attribute, -whose value is a list of strings. If a project defines the @code{Main} -attribute, it is not necessary to identify the main subprogram(s) when -invoking @command{gnatmake} (@pxref{gnatmake and Project Files}). - -@node Executable File Names -@unnumberedsubsubsec Executable File Names - -@noindent -By default, the executable file name corresponding to a main source is -deduced from the main source file name. Through the attributes -@code{Executable} and @code{Executable_Suffix} of package @code{Builder}, -it is possible to change this default. -In project @code{Debug} above, the executable file name -for main source @file{^proc.adb^PROC.ADB^} is -@file{^proc1^PROC1.EXE^}. -Attribute @code{Executable_Suffix}, when specified, may change the suffix -of the executable files, when no attribute @code{Executable} applies: -its value replace the platform-specific executable suffix. -Attributes @code{Executable} and @code{Executable_Suffix} are the only ways to -specify a non-default executable file name when several mains are built at once -in a single @command{gnatmake} command. - -@node Source File Naming Conventions -@unnumberedsubsubsec Source File Naming Conventions - -@noindent -Since the project files above do not specify any source file naming -conventions, the GNAT defaults are used. The mechanism for defining source -file naming conventions -- a package named @code{Naming} -- -is described below (@pxref{Naming Schemes}). - -@node Source Language(s) -@unnumberedsubsubsec Source Language(s) - -@noindent -Since the project files do not specify a @code{Languages} attribute, by -default the GNAT tools assume that the language of the project file is Ada. -More generally, a project can comprise source files -in Ada, C, and/or other languages. - -@node Using External Variables -@subsection Using External Variables - -@noindent -Instead of supplying different project files for debug and release, we can -define a single project file that queries an external variable (set either -on the command line or via an ^environment variable^logical name^) in order to -conditionally define the appropriate settings. Again, assume that the -source files @file{pack.ads}, @file{pack.adb}, and @file{proc.adb} are -located in directory @file{^/common^[COMMON]^}. The following project file, -@file{build.gpr}, queries the external variable named @code{STYLE} and -defines an object directory and ^switch^switch^ settings based on whether -the value is @code{"deb"} (debug) or @code{"rel"} (release), and where -the default is @code{"deb"}. - -@smallexample @c projectfile -@group -project Build is - for Main use ("proc"); - - type Style_Type is ("deb", "rel"); - Style : Style_Type := external ("STYLE", "deb"); - - case Style is - when "deb" => - for Object_Dir use "debug"; - - when "rel" => - for Object_Dir use "release"; - for Exec_Dir use "."; - end case; -@end group - -@group - package Builder is - - case Style is - when "deb" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for Executable ("proc") use "proc1"; - when others => - null; - end case; - - end Builder; -@end group - -@group - package Compiler is - - case Style is - when "deb" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnata^-gnata^", - "^-gnato^-gnato^", - "^-gnatE^-gnatE^"); - - when "rel" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-O2^-O2^"); - end case; - - end Compiler; - -end Build; -@end group -@end smallexample - -@noindent -@code{Style_Type} is an example of a @emph{string type}, which is the project -file analog of an Ada enumeration type but whose components are string literals -rather than identifiers. @code{Style} is declared as a variable of this type. - -The form @code{external("STYLE", "deb")} is known as an -@emph{external reference}; its first argument is the name of an -@emph{external variable}, and the second argument is a default value to be -used if the external variable doesn't exist. You can define an external -variable on the command line via the @option{^-X^/EXTERNAL_REFERENCE^} switch, -or you can use ^an environment variable^a logical name^ -as an external variable. - -Each @code{case} construct is expanded by the Project Manager based on the -value of @code{Style}. Thus the command -@ifclear vms -@smallexample -gnatmake -P/common/build.gpr -XSTYLE=deb -@end smallexample -@end ifclear - -@ifset vms -@smallexample -gnatmake /PROJECT_FILE=[COMMON]BUILD.GPR /EXTERNAL_REFERENCE=STYLE=deb -@end smallexample -@end ifset - -@noindent -is equivalent to the @command{gnatmake} invocation using the project file -@file{debug.gpr} in the earlier example. So is the command -@smallexample -gnatmake ^-P/common/build.gpr^/PROJECT_FILE=[COMMON]BUILD.GPR^ -@end smallexample - -@noindent -since @code{"deb"} is the default for @code{STYLE}. - -Analogously, - -@ifclear vms -@smallexample -gnatmake -P/common/build.gpr -XSTYLE=rel -@end smallexample -@end ifclear - -@ifset vms -@smallexample -GNAT MAKE /PROJECT_FILE=[COMMON]BUILD.GPR /EXTERNAL_REFERENCE=STYLE=rel -@end smallexample -@end ifset - -@noindent -is equivalent to the @command{gnatmake} invocation using the project file -@file{release.gpr} in the earlier example. - -@node Importing Other Projects -@subsection Importing Other Projects -@cindex @code{ADA_PROJECT_PATH} -@cindex @code{GPR_PROJECT_PATH} - -@noindent -A compilation unit in a source file in one project may depend on compilation -units in source files in other projects. To compile this unit under -control of a project file, the -dependent project must @emph{import} the projects containing the needed source -files. -This effect is obtained using syntax similar to an Ada @code{with} clause, -but where @code{with}ed entities are strings that denote project files. - -As an example, suppose that the two projects @code{GUI_Proj} and -@code{Comm_Proj} are defined in the project files @file{gui_proj.gpr} and -@file{comm_proj.gpr} in directories @file{^/gui^[GUI]^} -and @file{^/comm^[COMM]^}, respectively. -Suppose that the source files for @code{GUI_Proj} are -@file{gui.ads} and @file{gui.adb}, and that the source files for -@code{Comm_Proj} are @file{comm.ads} and @file{comm.adb}, where each set of -files is located in its respective project file directory. Schematically: - -@smallexample -@group -^/gui^[GUI]^ - gui_proj.gpr - gui.ads - gui.adb -@end group - -@group -^/comm^[COMM]^ - comm_proj.gpr - comm.ads - comm.adb -@end group -@end smallexample - -@noindent -We want to develop an application in directory @file{^/app^[APP]^} that -@code{with} the packages @code{GUI} and @code{Comm}, using the properties of -the corresponding project files (e.g.@: the ^switch^switch^ settings -and object directory). -Skeletal code for a main procedure might be something like the following: - -@smallexample @c ada -@group -with GUI, Comm; -procedure App_Main is - @dots{} -begin - @dots{} -end App_Main; -@end group -@end smallexample - -@noindent -Here is a project file, @file{app_proj.gpr}, that achieves the desired -effect: - -@smallexample @c projectfile -@group -with "/gui/gui_proj", "/comm/comm_proj"; -project App_Proj is - for Main use ("app_main"); -end App_Proj; -@end group -@end smallexample - -@noindent -Building an executable is achieved through the command: -@smallexample -gnatmake ^-P/app/app_proj^/PROJECT_FILE=[APP]APP_PROJ^ -@end smallexample -@noindent -which will generate the @code{^app_main^APP_MAIN.EXE^} executable -in the directory where @file{app_proj.gpr} resides. - -If an imported project file uses the standard extension (@code{^gpr^GPR^}) then -(as illustrated above) the @code{with} clause can omit the extension. - -Our example specified an absolute path for each imported project file. -Alternatively, the directory name of an imported object can be omitted -if either -@itemize @bullet -@item -The imported project file is in the same directory as the importing project -file, or -@item -You have defined one or two ^environment variables^logical names^ -that includes the directory containing -the needed project file. The syntax of @code{GPR_PROJECT_PATH} and -@code{ADA_PROJECT_PATH} is the same as -the syntax of @code{ADA_INCLUDE_PATH} and @code{ADA_OBJECTS_PATH}: a list of -directory names separated by colons (semicolons on Windows). -@end itemize - -@noindent -Thus, if we define @code{ADA_PROJECT_PATH} or @code{GPR_PROJECT_PATH} -to include @file{^/gui^[GUI]^} and -@file{^/comm^[COMM]^}, then our project file @file{app_proj.gpr} can be written -as follows: - -@smallexample @c projectfile -@group -with "gui_proj", "comm_proj"; -project App_Proj is - for Main use ("app_main"); -end App_Proj; -@end group -@end smallexample - -@noindent -Importing other projects can create ambiguities. -For example, the same unit might be present in different imported projects, or -it might be present in both the importing project and in an imported project. -Both of these conditions are errors. Note that in the current version of -the Project Manager, it is illegal to have an ambiguous unit even if the -unit is never referenced by the importing project. This restriction may be -relaxed in a future release. - -@node Extending a Project -@subsection Extending a Project - -@noindent -In large software systems it is common to have multiple -implementations of a common interface; in Ada terms, multiple versions of a -package body for the same spec. For example, one implementation -might be safe for use in tasking programs, while another might only be used -in sequential applications. This can be modeled in GNAT using the concept -of @emph{project extension}. If one project (the ``child'') @emph{extends} -another project (the ``parent'') then by default all source files of the -parent project are inherited by the child, but the child project can -override any of the parent's source files with new versions, and can also -add new files. This facility is the project analog of a type extension in -Object-Oriented Programming. Project hierarchies are permitted (a child -project may be the parent of yet another project), and a project that -inherits one project can also import other projects. - -As an example, suppose that directory @file{^/seq^[SEQ]^} contains the project -file @file{seq_proj.gpr} as well as the source files @file{pack.ads}, -@file{pack.adb}, and @file{proc.adb}: - -@smallexample -@group -^/seq^[SEQ]^ - pack.ads - pack.adb - proc.adb - seq_proj.gpr -@end group -@end smallexample - -@noindent -Note that the project file can simply be empty (that is, no attribute or -package is defined): - -@smallexample @c projectfile -@group -project Seq_Proj is -end Seq_Proj; -@end group -@end smallexample - -@noindent -implying that its source files are all the Ada source files in the project -directory. - -Suppose we want to supply an alternate version of @file{pack.adb}, in -directory @file{^/tasking^[TASKING]^}, but use the existing versions of -@file{pack.ads} and @file{proc.adb}. We can define a project -@code{Tasking_Proj} that inherits @code{Seq_Proj}: - -@smallexample -@group -^/tasking^[TASKING]^ - pack.adb - tasking_proj.gpr -@end group - -@group -project Tasking_Proj extends "/seq/seq_proj" is -end Tasking_Proj; -@end group -@end smallexample - -@noindent -The version of @file{pack.adb} used in a build depends on which project file -is specified. - -Note that we could have obtained the desired behavior using project import -rather than project inheritance; a @code{base} project would contain the -sources for @file{pack.ads} and @file{proc.adb}, a sequential project would -import @code{base} and add @file{pack.adb}, and likewise a tasking project -would import @code{base} and add a different version of @file{pack.adb}. The -choice depends on whether other sources in the original project need to be -overridden. If they do, then project extension is necessary, otherwise, -importing is sufficient. - -@noindent -In a project file that extends another project file, it is possible to -indicate that an inherited source is not part of the sources of the extending -project. This is necessary sometimes when a package spec has been overloaded -and no longer requires a body: in this case, it is necessary to indicate that -the inherited body is not part of the sources of the project, otherwise there -will be a compilation error when compiling the spec. - -For that purpose, the attribute @code{Excluded_Source_Files} is used. -Its value is a string list: a list of file names. It is also possible to use -attribute @code{Excluded_Source_List_File}. Its value is a single string: -the file name of a text file containing a list of file names, one per line. - -@smallexample @c @projectfile -project B extends "a" is - for Source_Files use ("pkg.ads"); - -- New spec of Pkg does not need a completion - for Excluded_Source_Files use ("pkg.adb"); -end B; -@end smallexample - -Attribute @code{Excluded_Source_Files} may also be used to check if a source -is still needed: if it is possible to build using @command{gnatmake} when such -a source is put in attribute @code{Excluded_Source_Files} of a project P, then -it is possible to remove the source completely from a system that includes -project P. - -@c *********************** -@c * Project File Syntax * -@c *********************** - -@node Project File Syntax -@section Project File Syntax - -@menu -* Basic Syntax:: -* Qualified Projects:: -* Packages:: -* Expressions:: -* String Types:: -* Variables:: -* Attributes:: -* Associative Array Attributes:: -* case Constructions:: -@end menu - -@noindent -This section describes the structure of project files. - -A project may be an @emph{independent project}, entirely defined by a single -project file. Any Ada source file in an independent project depends only -on the predefined library and other Ada source files in the same project. - -@noindent -A project may also @dfn{depend on} other projects, in either or both of -the following ways: -@itemize @bullet -@item It may import any number of projects -@item It may extend at most one other project -@end itemize - -@noindent -The dependence relation is a directed acyclic graph (the subgraph reflecting -the ``extends'' relation is a tree). - -A project's @dfn{immediate sources} are the source files directly defined by -that project, either implicitly by residing in the project file's directory, -or explicitly through any of the source-related attributes described below. -More generally, a project @var{proj}'s @dfn{sources} are the immediate sources -of @var{proj} together with the immediate sources (unless overridden) of any -project on which @var{proj} depends (either directly or indirectly). - -@node Basic Syntax -@subsection Basic Syntax - -@noindent -As seen in the earlier examples, project files have an Ada-like syntax. -The minimal project file is: -@smallexample @c projectfile -@group -project Empty is - -end Empty; -@end group -@end smallexample - -@noindent -The identifier @code{Empty} is the name of the project. -This project name must be present after the reserved -word @code{end} at the end of the project file, followed by a semi-colon. - -Any name in a project file, such as the project name or a variable name, -has the same syntax as an Ada identifier. - -The reserved words of project files are the Ada 95 reserved words plus -@code{extends}, @code{external}, and @code{project}. Note that the only Ada -reserved words currently used in project file syntax are: - -@itemize @bullet -@item -@code{all} -@item -@code{at} -@item -@code{case} -@item -@code{end} -@item -@code{for} -@item -@code{is} -@item -@code{limited} -@item -@code{null} -@item -@code{others} -@item -@code{package} -@item -@code{renames} -@item -@code{type} -@item -@code{use} -@item -@code{when} -@item -@code{with} -@end itemize - -@noindent -Comments in project files have the same syntax as in Ada, two consecutive -hyphens through the end of the line. - -@node Qualified Projects -@subsection Qualified Projects - -@noindent -Before the reserved @code{project}, there may be one or two "qualifiers", that -is identifiers or other reserved words, to qualify the project. - -The current list of qualifiers is: - -@itemize @bullet -@item -@code{abstract}: qualify a project with no sources. A qualified abstract -project must either have no declaration of attributes @code{Source_Dirs}, -@code{Source_Files}, @code{Languages} or @code{Source_List_File}, or one of -@code{Source_Dirs}, @code{Source_Files}, or @code{Languages} must be declared -as empty. If it extends another project, the project it extends must also be a -qualified abstract project. - -@item -@code{standard}: a standard project is a non library project with sources. - -@item -@code{aggregate}: for future extension - -@item -@code{aggregate library}: for future extension - -@item -@code{library}: a library project must declare both attributes -@code{Library_Name} and @code{Library_Dir}. - -@item -@code{configuration}: a configuration project cannot be in a project tree. -@end itemize - -@node Packages -@subsection Packages - -@noindent -A project file may contain @emph{packages}. The name of a package must be one -of the identifiers from the following list. A package -with a given name may only appear once in a project file. Package names are -case insensitive. The following package names are legal: - -@itemize @bullet -@item -@code{Naming} -@item -@code{Builder} -@item -@code{Compiler} -@item -@code{Binder} -@item -@code{Linker} -@item -@code{Finder} -@item -@code{Cross_Reference} -@item -@code{Check} -@item -@code{Eliminate} -@item -@code{Pretty_Printer} -@item -@code{Metrics} -@item -@code{gnatls} -@item -@code{gnatstub} -@item -@code{IDE} -@item -@code{Language_Processing} -@end itemize - -@noindent -In its simplest form, a package may be empty: - -@smallexample @c projectfile -@group -project Simple is - package Builder is - end Builder; -end Simple; -@end group -@end smallexample - -@noindent -A package may contain @emph{attribute declarations}, -@emph{variable declarations} and @emph{case constructions}, as will be -described below. - -When there is ambiguity between a project name and a package name, -the name always designates the project. To avoid possible confusion, it is -always a good idea to avoid naming a project with one of the -names allowed for packages or any name that starts with @code{gnat}. - -@node Expressions -@subsection Expressions - -@noindent -An @emph{expression} is either a @emph{string expression} or a -@emph{string list expression}. - -A @emph{string expression} is either a @emph{simple string expression} or a -@emph{compound string expression}. - -A @emph{simple string expression} is one of the following: -@itemize @bullet -@item A literal string; e.g.@: @code{"comm/my_proj.gpr"} -@item A string-valued variable reference (@pxref{Variables}) -@item A string-valued attribute reference (@pxref{Attributes}) -@item An external reference (@pxref{External References in Project Files}) -@end itemize - -@noindent -A @emph{compound string expression} is a concatenation of string expressions, -using the operator @code{"&"} -@smallexample - Path & "/" & File_Name & ".ads" -@end smallexample - -@noindent -A @emph{string list expression} is either a -@emph{simple string list expression} or a -@emph{compound string list expression}. - -A @emph{simple string list expression} is one of the following: -@itemize @bullet -@item A parenthesized list of zero or more string expressions, -separated by commas -@smallexample - File_Names := (File_Name, "gnat.adc", File_Name & ".orig"); - Empty_List := (); -@end smallexample -@item A string list-valued variable reference -@item A string list-valued attribute reference -@end itemize - -@noindent -A @emph{compound string list expression} is the concatenation (using -@code{"&"}) of a simple string list expression and an expression. Note that -each term in a compound string list expression, except the first, may be -either a string expression or a string list expression. - -@smallexample @c projectfile -@group - File_Name_List := () & File_Name; -- One string in this list - Extended_File_Name_List := File_Name_List & (File_Name & ".orig"); - -- Two strings - Big_List := File_Name_List & Extended_File_Name_List; - -- Concatenation of two string lists: three strings - Illegal_List := "gnat.adc" & Extended_File_Name_List; - -- Illegal: must start with a string list -@end group -@end smallexample - -@node String Types -@subsection String Types - -@noindent -A @emph{string type declaration} introduces a discrete set of string literals. -If a string variable is declared to have this type, its value -is restricted to the given set of literals. - -Here is an example of a string type declaration: - -@smallexample @c projectfile - type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS"); -@end smallexample - -@noindent -Variables of a string type are called @emph{typed variables}; all other -variables are called @emph{untyped variables}. Typed variables are -particularly useful in @code{case} constructions, to support conditional -attribute declarations. -(@pxref{case Constructions}). - -The string literals in the list are case sensitive and must all be different. -They may include any graphic characters allowed in Ada, including spaces. - -A string type may only be declared at the project level, not inside a package. - -A string type may be referenced by its name if it has been declared in the same -project file, or by an expanded name whose prefix is the name of the project -in which it is declared. - -@node Variables -@subsection Variables - -@noindent -A variable may be declared at the project file level, or within a package. -Here are some examples of variable declarations: - -@smallexample @c projectfile -@group - This_OS : OS := external ("OS"); -- a typed variable declaration - That_OS := "GNU/Linux"; -- an untyped variable declaration -@end group -@end smallexample - -@noindent -The syntax of a @emph{typed variable declaration} is identical to the Ada -syntax for an object declaration. By contrast, the syntax of an untyped -variable declaration is identical to an Ada assignment statement. In fact, -variable declarations in project files have some of the characteristics of -an assignment, in that successive declarations for the same variable are -allowed. Untyped variable declarations do establish the expected kind of the -variable (string or string list), and successive declarations for it must -respect the initial kind. - -@noindent -A string variable declaration (typed or untyped) declares a variable -whose value is a string. This variable may be used as a string expression. -@smallexample @c projectfile - File_Name := "readme.txt"; - Saved_File_Name := File_Name & ".saved"; -@end smallexample - -@noindent -A string list variable declaration declares a variable whose value is a list -of strings. The list may contain any number (zero or more) of strings. - -@smallexample @c projectfile - Empty_List := (); - List_With_One_Element := ("^-gnaty^-gnaty^"); - List_With_Two_Elements := List_With_One_Element & "^-gnatg^-gnatg^"; - Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada" - "pack2.ada", "util_.ada", "util.ada"); -@end smallexample - -@noindent -The same typed variable may not be declared more than once at project level, -and it may not be declared more than once in any package; it is in effect -a constant. - -The same untyped variable may be declared several times. Declarations are -elaborated in the order in which they appear, so the new value replaces -the old one, and any subsequent reference to the variable uses the new value. -However, as noted above, if a variable has been declared as a string, all -subsequent -declarations must give it a string value. Similarly, if a variable has -been declared as a string list, all subsequent declarations -must give it a string list value. - -A @emph{variable reference} may take several forms: - -@itemize @bullet -@item The simple variable name, for a variable in the current package (if any) -or in the current project -@item An expanded name, whose prefix is a context name. -@end itemize - -@noindent -A @emph{context} may be one of the following: - -@itemize @bullet -@item The name of an existing package in the current project -@item The name of an imported project of the current project -@item The name of an ancestor project (i.e., a project extended by the current -project, either directly or indirectly) -@item An expanded name whose prefix is an imported/parent project name, and -whose selector is a package name in that project. -@end itemize - -@noindent -A variable reference may be used in an expression. - -@node Attributes -@subsection Attributes - -@noindent -A project (and its packages) may have @emph{attributes} that define -the project's properties. Some attributes have values that are strings; -others have values that are string lists. - -There are two categories of attributes: @emph{simple attributes} -and @emph{associative arrays} (@pxref{Associative Array Attributes}). - -Legal project attribute names, and attribute names for each legal package are -listed below. Attributes names are case-insensitive. - -The following attributes are defined on projects (all are simple attributes): - -@multitable @columnfractions .4 .3 -@item @emph{Attribute Name} -@tab @emph{Value} -@item @code{Source_Files} -@tab string list -@item @code{Source_Dirs} -@tab string list -@item @code{Source_List_File} -@tab string -@item @code{Object_Dir} -@tab string -@item @code{Exec_Dir} -@tab string -@item @code{Excluded_Source_Dirs} -@tab string list -@item @code{Excluded_Source_Files} -@tab string list -@item @code{Excluded_Source_List_File} -@tab string -@item @code{Languages} -@tab string list -@item @code{Main} -@tab string list -@item @code{Library_Dir} -@tab string -@item @code{Library_Name} -@tab string -@item @code{Library_Kind} -@tab string -@item @code{Library_Version} -@tab string -@item @code{Library_Interface} -@tab string -@item @code{Library_Auto_Init} -@tab string -@item @code{Library_Options} -@tab string list -@item @code{Library_Src_Dir} -@tab string -@item @code{Library_ALI_Dir} -@tab string -@item @code{Library_GCC} -@tab string -@item @code{Library_Symbol_File} -@tab string -@item @code{Library_Symbol_Policy} -@tab string -@item @code{Library_Reference_Symbol_File} -@tab string -@item @code{Externally_Built} -@tab string -@end multitable - -@noindent -The following attributes are defined for package @code{Naming} -(@pxref{Naming Schemes}): - -@multitable @columnfractions .4 .2 .2 .2 -@item Attribute Name @tab Category @tab Index @tab Value -@item @code{Spec_Suffix} -@tab associative array -@tab language name -@tab string -@item @code{Body_Suffix} -@tab associative array -@tab language name -@tab string -@item @code{Separate_Suffix} -@tab simple attribute -@tab n/a -@tab string -@item @code{Casing} -@tab simple attribute -@tab n/a -@tab string -@item @code{Dot_Replacement} -@tab simple attribute -@tab n/a -@tab string -@item @code{Spec} -@tab associative array -@tab Ada unit name -@tab string -@item @code{Body} -@tab associative array -@tab Ada unit name -@tab string -@item @code{Specification_Exceptions} -@tab associative array -@tab language name -@tab string list -@item @code{Implementation_Exceptions} -@tab associative array -@tab language name -@tab string list -@end multitable - -@noindent -The following attributes are defined for packages @code{Builder}, -@code{Compiler}, @code{Binder}, -@code{Linker}, @code{Cross_Reference}, and @code{Finder} -(@pxref{^Switches^Switches^ and Project Files}). - -@multitable @columnfractions .4 .2 .2 .2 -@item Attribute Name @tab Category @tab Index @tab Value -@item @code{^Default_Switches^Default_Switches^} -@tab associative array -@tab language name -@tab string list -@item @code{^Switches^Switches^} -@tab associative array -@tab file name -@tab string list -@end multitable - -@noindent -In addition, package @code{Compiler} has a single string attribute -@code{Local_Configuration_Pragmas} and package @code{Builder} has a single -string attribute @code{Global_Configuration_Pragmas}. - -@noindent -Each simple attribute has a default value: the empty string (for string-valued -attributes) and the empty list (for string list-valued attributes). - -An attribute declaration defines a new value for an attribute. - -Examples of simple attribute declarations: - -@smallexample @c projectfile - for Object_Dir use "objects"; - for Source_Dirs use ("units", "test/drivers"); -@end smallexample - -@noindent -The syntax of a @dfn{simple attribute declaration} is similar to that of an -attribute definition clause in Ada. - -Attributes references may be appear in expressions. -The general form for such a reference is @code{<entity>'<attribute>}: -Associative array attributes are functions. Associative -array attribute references must have an argument that is a string literal. - -Examples are: - -@smallexample @c projectfile - project'Object_Dir - Naming'Dot_Replacement - Imported_Project'Source_Dirs - Imported_Project.Naming'Casing - Builder'^Default_Switches^Default_Switches^("Ada") -@end smallexample - -@noindent -The prefix of an attribute may be: -@itemize @bullet -@item @code{project} for an attribute of the current project -@item The name of an existing package of the current project -@item The name of an imported project -@item The name of a parent project that is extended by the current project -@item An expanded name whose prefix is imported/parent project name, -and whose selector is a package name -@end itemize - -@noindent -Example: -@smallexample @c projectfile -@group - project Prj is - for Source_Dirs use project'Source_Dirs & "units"; - for Source_Dirs use project'Source_Dirs & "test/drivers" - end Prj; -@end group -@end smallexample - -@noindent -In the first attribute declaration, initially the attribute @code{Source_Dirs} -has the default value: an empty string list. After this declaration, -@code{Source_Dirs} is a string list of one element: @code{"units"}. -After the second attribute declaration @code{Source_Dirs} is a string list of -two elements: @code{"units"} and @code{"test/drivers"}. - -Note: this example is for illustration only. In practice, -the project file would contain only one attribute declaration: - -@smallexample @c projectfile - for Source_Dirs use ("units", "test/drivers"); -@end smallexample - -@node Associative Array Attributes -@subsection Associative Array Attributes - -@noindent -Some attributes are defined as @emph{associative arrays}. An associative -array may be regarded as a function that takes a string as a parameter -and delivers a string or string list value as its result. - -Here are some examples of single associative array attribute associations: - -@smallexample @c projectfile - for Body ("main") use "Main.ada"; - for ^Switches^Switches^ ("main.ada") - use ("^-v^-v^", - "^-gnatv^-gnatv^"); - for ^Switches^Switches^ ("main.ada") - use Builder'^Switches^Switches^ ("main.ada") - & "^-g^-g^"; -@end smallexample - -@noindent -Like untyped variables and simple attributes, associative array attributes -may be declared several times. Each declaration supplies a new value for the -attribute, and replaces the previous setting. - -@noindent -An associative array attribute may be declared as a full associative array -declaration, with the value of the same attribute in an imported or extended -project. - -@smallexample @c projectfile - package Builder is - for Default_Switches use Default.Builder'Default_Switches; - end Builder; -@end smallexample - -@noindent -In this example, @code{Default} must be either a project imported by the -current project, or the project that the current project extends. If the -attribute is in a package (in this case, in package @code{Builder}), the same -package needs to be specified. - -@noindent -A full associative array declaration replaces any other declaration for the -attribute, including other full associative array declaration. Single -associative array associations may be declare after a full associative -declaration, modifying the value for a single association of the attribute. - -@node case Constructions -@subsection @code{case} Constructions - -@noindent -A @code{case} construction is used in a project file to effect conditional -behavior. -Here is a typical example: - -@smallexample @c projectfile -@group -project MyProj is - type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS"); - - OS : OS_Type := external ("OS", "GNU/Linux"); -@end group - -@group - package Compiler is - case OS is - when "GNU/Linux" | "Unix" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnath^-gnath^"); - when "NT" => - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnatP^-gnatP^"); - when others => - end case; - end Compiler; -end MyProj; -@end group -@end smallexample - -@noindent -The syntax of a @code{case} construction is based on the Ada case statement -(although there is no @code{null} construction for empty alternatives). - -The case expression must be a typed string variable. -Each alternative comprises the reserved word @code{when}, either a list of -literal strings separated by the @code{"|"} character or the reserved word -@code{others}, and the @code{"=>"} token. -Each literal string must belong to the string type that is the type of the -case variable. -An @code{others} alternative, if present, must occur last. - -After each @code{=>}, there are zero or more constructions. The only -constructions allowed in a case construction are other case constructions, -attribute declarations and variable declarations. String type declarations and -package declarations are not allowed. Variable declarations are restricted to -variables that have already been declared before the case construction. - -The value of the case variable is often given by an external reference -(@pxref{External References in Project Files}). - -@c **************************************** -@c * Objects and Sources in Project Files * -@c **************************************** - -@node Objects and Sources in Project Files -@section Objects and Sources in Project Files - -@menu -* Object Directory:: -* Exec Directory:: -* Source Directories:: -* Source File Names:: -@end menu - -@noindent -Each project has exactly one object directory and one or more source -directories. The source directories must contain at least one source file, -unless the project file explicitly specifies that no source files are present -(@pxref{Source File Names}). - -@node Object Directory -@subsection Object Directory - -@noindent -The object directory for a project is the directory containing the compiler's -output (such as @file{ALI} files and object files) for the project's immediate -sources. - -The object directory is given by the value of the attribute @code{Object_Dir} -in the project file. - -@smallexample @c projectfile - for Object_Dir use "objects"; -@end smallexample - -@noindent -The attribute @code{Object_Dir} has a string value, the path name of the object -directory. The path name may be absolute or relative to the directory of the -project file. This directory must already exist, and be readable and writable. - -By default, when the attribute @code{Object_Dir} is not given an explicit value -or when its value is the empty string, the object directory is the same as the -directory containing the project file. - -@node Exec Directory -@subsection Exec Directory - -@noindent -The exec directory for a project is the directory containing the executables -for the project's main subprograms. - -The exec directory is given by the value of the attribute @code{Exec_Dir} -in the project file. - -@smallexample @c projectfile - for Exec_Dir use "executables"; -@end smallexample - -@noindent -The attribute @code{Exec_Dir} has a string value, the path name of the exec -directory. The path name may be absolute or relative to the directory of the -project file. This directory must already exist, and be writable. - -By default, when the attribute @code{Exec_Dir} is not given an explicit value -or when its value is the empty string, the exec directory is the same as the -object directory of the project file. - -@node Source Directories -@subsection Source Directories - -@noindent -The source directories of a project are specified by the project file -attribute @code{Source_Dirs}. - -This attribute's value is a string list. If the attribute is not given an -explicit value, then there is only one source directory, the one where the -project file resides. - -A @code{Source_Dirs} attribute that is explicitly defined to be the empty list, -as in - -@smallexample @c projectfile - for Source_Dirs use (); -@end smallexample - -@noindent -indicates that the project contains no source files. - -Otherwise, each string in the string list designates one or more -source directories. - -@smallexample @c projectfile - for Source_Dirs use ("sources", "test/drivers"); -@end smallexample - -@noindent -If a string in the list ends with @code{"/**"}, then the directory whose path -name precedes the two asterisks, as well as all its subdirectories -(recursively), are source directories. - -@smallexample @c projectfile - for Source_Dirs use ("/system/sources/**"); -@end smallexample - -@noindent -Here the directory @code{/system/sources} and all of its subdirectories -(recursively) are source directories. - -To specify that the source directories are the directory of the project file -and all of its subdirectories, you can declare @code{Source_Dirs} as follows: -@smallexample @c projectfile - for Source_Dirs use ("./**"); -@end smallexample - -@noindent -Each of the source directories must exist and be readable. - -@node Source File Names -@subsection Source File Names - -@noindent -In a project that contains source files, their names may be specified by the -attributes @code{Source_Files} (a string list) or @code{Source_List_File} -(a string). Source file names never include any directory information. - -If the attribute @code{Source_Files} is given an explicit value, then each -element of the list is a source file name. - -@smallexample @c projectfile - for Source_Files use ("main.adb"); - for Source_Files use ("main.adb", "pack1.ads", "pack2.adb"); -@end smallexample - -@noindent -If the attribute @code{Source_Files} is not given an explicit value, -but the attribute @code{Source_List_File} is given a string value, -then the source file names are contained in the text file whose path name -(absolute or relative to the directory of the project file) is the -value of the attribute @code{Source_List_File}. - -Each line in the file that is not empty or is not a comment -contains a source file name. - -@smallexample @c projectfile - for Source_List_File use "source_list.txt"; -@end smallexample - -@noindent -By default, if neither the attribute @code{Source_Files} nor the attribute -@code{Source_List_File} is given an explicit value, then each file in the -source directories that conforms to the project's naming scheme -(@pxref{Naming Schemes}) is an immediate source of the project. - -A warning is issued if both attributes @code{Source_Files} and -@code{Source_List_File} are given explicit values. In this case, the attribute -@code{Source_Files} prevails. - -Each source file name must be the name of one existing source file -in one of the source directories. - -A @code{Source_Files} attribute whose value is an empty list -indicates that there are no source files in the project. - -If the order of the source directories is known statically, that is if -@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may -be several files with the same source file name. In this case, only the file -in the first directory is considered as an immediate source of the project -file. If the order of the source directories is not known statically, it is -an error to have several files with the same source file name. - -Projects can be specified to have no Ada source -files: the value of @code{Source_Dirs} or @code{Source_Files} may be an empty -list, or the @code{"Ada"} may be absent from @code{Languages}: - -@smallexample @c projectfile - for Source_Dirs use (); - for Source_Files use (); - for Languages use ("C", "C++"); -@end smallexample - -@noindent -Otherwise, a project must contain at least one immediate source. - -Projects with no source files are useful as template packages -(@pxref{Packages in Project Files}) for other projects; in particular to -define a package @code{Naming} (@pxref{Naming Schemes}). - -@c **************************** -@c * Importing Projects * -@c **************************** - -@node Importing Projects -@section Importing Projects -@cindex @code{ADA_PROJECT_PATH} -@cindex @code{GPR_PROJECT_PATH} - -@noindent -An immediate source of a project P may depend on source files that -are neither immediate sources of P nor in the predefined library. -To get this effect, P must @emph{import} the projects that contain the needed -source files. - -@smallexample @c projectfile -@group - with "project1", "utilities.gpr"; - with "/namings/apex.gpr"; - project Main is - @dots{} -@end group -@end smallexample - -@noindent -As can be seen in this example, the syntax for importing projects is similar -to the syntax for importing compilation units in Ada. However, project files -use literal strings instead of names, and the @code{with} clause identifies -project files rather than packages. - -Each literal string is the file name or path name (absolute or relative) of a -project file. If a string corresponds to a file name, with no path or a -relative path, then its location is determined by the @emph{project path}. The -latter can be queried using @code{gnatls -v}. It contains: - -@itemize @bullet -@item -In first position, the directory containing the current project file. -@item -In last position, the default project directory. This default project directory -is part of the GNAT installation and is the standard place to install project -files giving access to standard support libraries. -@ifclear vms -@ref{Installing a library} -@end ifclear - -@item -In between, all the directories referenced in the -^environment variables^logical names^ @env{GPR_PROJECT_PATH} -and @env{ADA_PROJECT_PATH} if they exist, and in that order. -@end itemize - -@noindent -If a relative pathname is used, as in - -@smallexample @c projectfile - with "tests/proj"; -@end smallexample - -@noindent -then the full path for the project is constructed by concatenating this -relative path to those in the project path, in order, until a matching file is -found. Any symbolic link will be fully resolved in the directory of the -importing project file before the imported project file is examined. - -If the @code{with}'ed project file name does not have an extension, -the default is @file{^.gpr^.GPR^}. If a file with this extension is not found, -then the file name as specified in the @code{with} clause (no extension) will -be used. In the above example, if a file @code{project1.gpr} is found, then it -will be used; otherwise, if a file @code{^project1^PROJECT1^} exists -then it will be used; if neither file exists, this is an error. - -A warning is issued if the name of the project file does not match the -name of the project; this check is case insensitive. - -Any source file that is an immediate source of the imported project can be -used by the immediate sources of the importing project, transitively. Thus -if @code{A} imports @code{B}, and @code{B} imports @code{C}, the immediate -sources of @code{A} may depend on the immediate sources of @code{C}, even if -@code{A} does not import @code{C} explicitly. However, this is not recommended, -because if and when @code{B} ceases to import @code{C}, some sources in -@code{A} will no longer compile. - -A side effect of this capability is that normally cyclic dependencies are not -permitted: if @code{A} imports @code{B} (directly or indirectly) then @code{B} -is not allowed to import @code{A}. However, there are cases when cyclic -dependencies would be beneficial. For these cases, another form of import -between projects exists, the @code{limited with}: a project @code{A} that -imports a project @code{B} with a straight @code{with} may also be imported, -directly or indirectly, by @code{B} on the condition that imports from @code{B} -to @code{A} include at least one @code{limited with}. - -@smallexample @c 0projectfile -with "../b/b.gpr"; -with "../c/c.gpr"; -project A is -end A; - -limited with "../a/a.gpr"; -project B is -end B; - -with "../d/d.gpr"; -project C is -end C; - -limited with "../a/a.gpr"; -project D is -end D; -@end smallexample - -@noindent -In the above legal example, there are two project cycles: -@itemize @bullet -@item A-> B-> A -@item A -> C -> D -> A -@end itemize - -@noindent -In each of these cycle there is one @code{limited with}: import of @code{A} -from @code{B} and import of @code{A} from @code{D}. - -The difference between straight @code{with} and @code{limited with} is that -the name of a project imported with a @code{limited with} cannot be used in the -project that imports it. In particular, its packages cannot be renamed and -its variables cannot be referred to. - -An exception to the above rules for @code{limited with} is that for the main -project specified to @command{gnatmake} or to the @command{GNAT} driver a -@code{limited with} is equivalent to a straight @code{with}. For example, -in the example above, projects @code{B} and @code{D} could not be main -projects for @command{gnatmake} or to the @command{GNAT} driver, because they -each have a @code{limited with} that is the only one in a cycle of importing -projects. - -@c ********************* -@c * Project Extension * -@c ********************* - -@node Project Extension -@section Project Extension - -@noindent -During development of a large system, it is sometimes necessary to use -modified versions of some of the source files, without changing the original -sources. This can be achieved through the @emph{project extension} facility. - -@smallexample @c projectfile - project Modified_Utilities extends "/baseline/utilities.gpr" is @dots{} -@end smallexample - -@noindent -A project extension declaration introduces an extending project -(the @emph{child}) and a project being extended (the @emph{parent}). - -By default, a child project inherits all the sources of its parent. -However, inherited sources can be overridden: a unit in a parent is hidden -by a unit of the same name in the child. - -Inherited sources are considered to be sources (but not immediate sources) -of the child project; see @ref{Project File Syntax}. - -An inherited source file retains any switches specified in the parent project. - -For example if the project @code{Utilities} contains the spec and the -body of an Ada package @code{Util_IO}, then the project -@code{Modified_Utilities} can contain a new body for package @code{Util_IO}. -The original body of @code{Util_IO} will not be considered in program builds. -However, the package spec will still be found in the project -@code{Utilities}. - -A child project can have only one parent, except when it is qualified as -abstract. But it may import any number of other projects. - -A project is not allowed to import directly or indirectly at the same time a -child project and any of its ancestors. - -@c ******************************* -@c * Project Hierarchy Extension * -@c ******************************* - -@node Project Hierarchy Extension -@section Project Hierarchy Extension - -@noindent -When extending a large system spanning multiple projects, it is often -inconvenient to extend every project in the hierarchy that is impacted by a -small change introduced. In such cases, it is possible to create a virtual -extension of entire hierarchy using @code{extends all} relationship. - -When the project is extended using @code{extends all} inheritance, all projects -that are imported by it, both directly and indirectly, are considered virtually -extended. That is, the Project Manager creates "virtual projects" -that extend every project in the hierarchy; all these virtual projects have -no sources of their own and have as object directory the object directory of -the root of "extending all" project. - -It is possible to explicitly extend one or more projects in the hierarchy -in order to modify the sources. These extending projects must be imported by -the "extending all" project, which will replace the corresponding virtual -projects with the explicit ones. - -When building such a project hierarchy extension, the Project Manager will -ensure that both modified sources and sources in virtual extending projects -that depend on them, are recompiled. - -By means of example, consider the following hierarchy of projects. - -@enumerate -@item -project A, containing package P1 -@item -project B importing A and containing package P2 which depends on P1 -@item -project C importing B and containing package P3 which depends on P2 -@end enumerate - -@noindent -We want to modify packages P1 and P3. - -This project hierarchy will need to be extended as follows: - -@enumerate -@item -Create project A1 that extends A, placing modified P1 there: - -@smallexample @c 0projectfile -project A1 extends "(@dots{})/A" is -end A1; -@end smallexample - -@item -Create project C1 that "extends all" C and imports A1, placing modified -P3 there: - -@smallexample @c 0projectfile -with "(@dots{})/A1"; -project C1 extends all "(@dots{})/C" is -end C1; -@end smallexample -@end enumerate - -When you build project C1, your entire modified project space will be -recompiled, including the virtual project B1 that has been impacted by the -"extending all" inheritance of project C. - -Note that if a Library Project in the hierarchy is virtually extended, -the virtual project that extends the Library Project is not a Library Project. - -@c **************************************** -@c * External References in Project Files * -@c **************************************** - -@node External References in Project Files -@section External References in Project Files - -@noindent -A project file may contain references to external variables; such references -are called @emph{external references}. - -An external variable is either defined as part of the environment (an -environment variable in Unix, for example) or else specified on the command -line via the @option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. -If both, then the command line value is used. - -The value of an external reference is obtained by means of the built-in -function @code{external}, which returns a string value. -This function has two forms: -@itemize @bullet -@item @code{external (external_variable_name)} -@item @code{external (external_variable_name, default_value)} -@end itemize - -@noindent -Each parameter must be a string literal. For example: - -@smallexample @c projectfile - external ("USER") - external ("OS", "GNU/Linux") -@end smallexample - -@noindent -In the form with one parameter, the function returns the value of -the external variable given as parameter. If this name is not present in the -environment, the function returns an empty string. - -In the form with two string parameters, the second argument is -the value returned when the variable given as the first argument is not -present in the environment. In the example above, if @code{"OS"} is not -the name of ^an environment variable^a logical name^ and is not passed on -the command line, then the returned value is @code{"GNU/Linux"}. - -An external reference may be part of a string expression or of a string -list expression, and can therefore appear in a variable declaration or -an attribute declaration. - -@smallexample @c projectfile -@group - type Mode_Type is ("Debug", "Release"); - Mode : Mode_Type := external ("MODE"); - case Mode is - when "Debug" => - @dots{} -@end group -@end smallexample - -@c ***************************** -@c * Packages in Project Files * -@c ***************************** - -@node Packages in Project Files -@section Packages in Project Files - -@noindent -A @emph{package} defines the settings for project-aware tools within a -project. -For each such tool one can declare a package; the names for these -packages are preset (@pxref{Packages}). -A package may contain variable declarations, attribute declarations, and case -constructions. - -@smallexample @c projectfile -@group - project Proj is - package Builder is -- used by gnatmake - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-v^-v^", - "^-g^-g^"); - end Builder; - end Proj; -@end group -@end smallexample - -@noindent -The syntax of package declarations mimics that of package in Ada. - -Most of the packages have an attribute -@code{^Default_Switches^Default_Switches^}. -This attribute is an associative array, and its value is a string list. -The index of the associative array is the name of a programming language (case -insensitive). This attribute indicates the ^switch^switch^ -or ^switches^switches^ to be used -with the corresponding tool. - -Some packages also have another attribute, @code{^Switches^Switches^}, -an associative array whose value is a string list. -The index is the name of a source file. -This attribute indicates the ^switch^switch^ -or ^switches^switches^ to be used by the corresponding -tool when dealing with this specific file. - -Further information on these ^switch^switch^-related attributes is found in -@ref{^Switches^Switches^ and Project Files}. - -A package may be declared as a @emph{renaming} of another package; e.g., from -the project file for an imported project. - -@smallexample @c projectfile -@group - with "/global/apex.gpr"; - project Example is - package Naming renames Apex.Naming; - @dots{} - end Example; -@end group -@end smallexample - -@noindent -Packages that are renamed in other project files often come from project files -that have no sources: they are just used as templates. Any modification in the -template will be reflected automatically in all the project files that rename -a package from the template. - -In addition to the tool-oriented packages, you can also declare a package -named @code{Naming} to establish specialized source file naming conventions -(@pxref{Naming Schemes}). - -@c ************************************ -@c * Variables from Imported Projects * -@c ************************************ - -@node Variables from Imported Projects -@section Variables from Imported Projects - -@noindent -An attribute or variable defined in an imported or parent project can -be used in expressions in the importing / extending project. -Such an attribute or variable is denoted by an expanded name whose prefix -is either the name of the project or the expanded name of a package within -a project. - -@smallexample @c projectfile -@group - with "imported"; - project Main extends "base" is - Var1 := Imported.Var; - Var2 := Base.Var & ".new"; -@end group - -@group - package Builder is - for ^Default_Switches^Default_Switches^ ("Ada") - use Imported.Builder'Ada_^Switches^Switches^ & - "^-gnatg^-gnatg^" & - "^-v^-v^"; - end Builder; -@end group - -@group - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use Base.Compiler'Ada_^Switches^Switches^; - end Compiler; - end Main; -@end group -@end smallexample - -@noindent -In this example: - -@itemize @bullet -@item -The value of @code{Var1} is a copy of the variable @code{Var} defined -in the project file @file{"imported.gpr"} -@item -the value of @code{Var2} is a copy of the value of variable @code{Var} -defined in the project file @file{base.gpr}, concatenated with @code{".new"} -@item -attribute @code{^Default_Switches^Default_Switches^ ("Ada")} in package -@code{Builder} is a string list that includes in its value a copy of the value -of @code{Ada_^Switches^Switches^} defined in the @code{Builder} package -in project file @file{imported.gpr} plus two new elements: -@option{"^-gnatg^-gnatg^"} -and @option{"^-v^-v^"}; -@item -attribute @code{^Default_Switches^Default_Switches^ ("Ada")} in package -@code{Compiler} is a copy of the variable @code{Ada_^Switches^Switches^} -defined in the @code{Compiler} package in project file @file{base.gpr}, -the project being extended. -@end itemize - -@c ****************** -@c * Naming Schemes * -@c ****************** - -@node Naming Schemes -@section Naming Schemes - -@noindent -Sometimes an Ada software system is ported from a foreign compilation -environment to GNAT, and the file names do not use the default GNAT -conventions. Instead of changing all the file names (which for a variety -of reasons might not be possible), you can define the relevant file -naming scheme in the @code{Naming} package in your project file. - -@noindent -Note that the use of pragmas described in -@ref{Alternative File Naming Schemes} by mean of a configuration -pragmas file is not supported when using project files. You must use -the features described in this paragraph. You can however use specify -other configuration pragmas (@pxref{Specifying Configuration Pragmas}). - -@ifclear vms -For example, the following -package models the Apex file naming rules: - -@smallexample @c projectfile -@group - package Naming is - for Casing use "lowercase"; - for Dot_Replacement use "."; - for Spec_Suffix ("Ada") use ".1.ada"; - for Body_Suffix ("Ada") use ".2.ada"; - end Naming; -@end group -@end smallexample -@end ifclear - -@ifset vms -For example, the following package models the HP Ada file naming rules: - -@smallexample @c projectfile -@group - package Naming is - for Casing use "lowercase"; - for Dot_Replacement use "__"; - for Spec_Suffix ("Ada") use "_.^ada^ada^"; - for Body_Suffix ("Ada") use ".^ada^ada^"; - end Naming; -@end group -@end smallexample - -@noindent -(Note that @code{Casing} is @code{"lowercase"} because GNAT gets the file -names in lower case) -@end ifset - -@noindent -You can define the following attributes in package @code{Naming}: - -@table @code - -@item @code{Casing} -This must be a string with one of the three values @code{"lowercase"}, -@code{"uppercase"} or @code{"mixedcase"}; these strings are case insensitive. - -@noindent -If @code{Casing} is not specified, then the default is @code{"lowercase"}. - -@item @code{Dot_Replacement} -This must be a string whose value satisfies the following conditions: - -@itemize @bullet -@item It must not be empty -@item It cannot start or end with an alphanumeric character -@item It cannot be a single underscore -@item It cannot start with an underscore followed by an alphanumeric -@item It cannot contain a dot @code{'.'} except if the entire string -is @code{"."} -@end itemize - -@noindent -If @code{Dot_Replacement} is not specified, then the default is @code{"-"}. - -@item @code{Spec_Suffix} -This is an associative array (indexed by the programming language name, case -insensitive) whose value is a string that must satisfy the following -conditions: - -@itemize @bullet -@item It must not be empty -@item It must include at least one dot -@end itemize -@noindent -If @code{Spec_Suffix ("Ada")} is not specified, then the default is -@code{"^.ads^.ADS^"}. - -@item @code{Body_Suffix} -This is an associative array (indexed by the programming language name, case -insensitive) whose value is a string that must satisfy the following -conditions: - -@itemize @bullet -@item It must not be empty -@item It must include at least one dot -@item It cannot be the same as @code{Spec_Suffix ("Ada")} -@end itemize -@noindent -If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the -same string, then a file name that ends with the longest of these two suffixes -will be a body if the longest suffix is @code{Body_Suffix ("Ada")} or a spec -if the longest suffix is @code{Spec_Suffix ("Ada")}. - -If the suffix does not start with a '.', a file with a name exactly equal -to the suffix will also be part of the project (for instance if you define -the suffix as @code{Makefile}, a file called @file{Makefile} will be part -of the project. This is not interesting in general when using projects to -compile. However, it might become useful when a project is also used to -find the list of source files in an editor, like the GNAT Programming System -(GPS). - -If @code{Body_Suffix ("Ada")} is not specified, then the default is -@code{"^.adb^.ADB^"}. - -@item @code{Separate_Suffix} -This must be a string whose value satisfies the same conditions as -@code{Body_Suffix}. The same "longest suffix" rules apply. - -@noindent -If @code{Separate_Suffix ("Ada")} is not specified, then it defaults to same -value as @code{Body_Suffix ("Ada")}. - -@item @code{Spec} -@noindent -You can use the associative array attribute @code{Spec} to define -the source file name for an individual Ada compilation unit's spec. The array -index must be a string literal that identifies the Ada unit (case insensitive). -The value of this attribute must be a string that identifies the file that -contains this unit's spec (case sensitive or insensitive depending on the -operating system). - -@smallexample @c projectfile - for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; -@end smallexample - -When the source file contains several units, you can indicate at what -position the unit occurs in the file, with the following. The first unit -in the file has index 1 - -@smallexample @c projectfile - for Body ("top") use "foo.a" at 1; - for Body ("foo") use "foo.a" at 2; -@end smallexample - -@item @code{Body} - -You can use the associative array attribute @code{Body} to -define the source file name for an individual Ada compilation unit's body -(possibly a subunit). The array index must be a string literal that identifies -the Ada unit (case insensitive). The value of this attribute must be a string -that identifies the file that contains this unit's body or subunit (case -sensitive or insensitive depending on the operating system). - -@smallexample @c projectfile - for Body ("MyPack.MyChild") use "mypack.mychild.body"; -@end smallexample -@end table - -@c ******************** -@c * Library Projects * -@c ******************** - -@node Library Projects -@section Library Projects - -@noindent -@emph{Library projects} are projects whose object code is placed in a library. -(Note that this facility is not yet supported on all platforms). - -@code{gnatmake} or @code{gprbuild} will collect all object files into a -single archive, which might either be a shared or a static library. This -library can later on be linked with multiple executables, potentially -reducing their sizes. - -If your project file specifies languages other than Ada, but you are still -using @code{gnatmake} to compile and link, the latter will not try to -compile your sources other than Ada (you should use @code{gprbuild} if that -is your intent). However, @code{gnatmake} will automatically link all object -files found in the object directory, whether or not they were compiled from -an Ada source file. This specific behavior only applies when multiple -languages are specified. - -To create a library project, you need to define in its project file -two project-level attributes: @code{Library_Name} and @code{Library_Dir}. -Additionally, you may define other library-related attributes such as -@code{Library_Kind}, @code{Library_Version}, @code{Library_Interface}, -@code{Library_Auto_Init}, @code{Library_Options} and @code{Library_GCC}. - -The @code{Library_Name} attribute has a string value. There is no restriction -on the name of a library. It is the responsibility of the developer to -choose a name that will be accepted by the platform. It is recommended to -choose names that could be Ada identifiers; such names are almost guaranteed -to be acceptable on all platforms. - -The @code{Library_Dir} attribute has a string value that designates the path -(absolute or relative) of the directory where the library will reside. -It must designate an existing directory, and this directory must be writable, -different from the project's object directory and from any source directory -in the project tree. - -If both @code{Library_Name} and @code{Library_Dir} are specified and -are legal, then the project file defines a library project. The optional -library-related attributes are checked only for such project files. - -The @code{Library_Kind} attribute has a string value that must be one of the -following (case insensitive): @code{"static"}, @code{"dynamic"} or -@code{"relocatable"} (which is a synonym for @code{"dynamic"}). If this -attribute is not specified, the library is a static library, that is -an archive of object files that can be potentially linked into a -static executable. Otherwise, the library may be dynamic or -relocatable, that is a library that is loaded only at the start of execution. - -If you need to build both a static and a dynamic library, you should use two -different object directories, since in some cases some extra code needs to -be generated for the latter. For such cases, it is recommended to either use -two different project files, or a single one which uses external variables -to indicate what kind of library should be build. - -The @code{Library_ALI_Dir} attribute may be specified to indicate the -directory where the ALI files of the library will be copied. When it is -not specified, the ALI files are copied to the directory specified in -attribute @code{Library_Dir}. The directory specified by @code{Library_ALI_Dir} -must be writable and different from the project's object directory and from -any source directory in the project tree. - -The @code{Library_Version} attribute has a string value whose interpretation -is platform dependent. It has no effect on VMS and Windows. On Unix, it is -used only for dynamic/relocatable libraries as the internal name of the -library (the @code{"soname"}). If the library file name (built from the -@code{Library_Name}) is different from the @code{Library_Version}, then the -library file will be a symbolic link to the actual file whose name will be -@code{Library_Version}. - -Example (on Unix): - -@smallexample @c projectfile -@group -project Plib is - - Version := "1"; - - for Library_Dir use "lib_dir"; - for Library_Name use "dummy"; - for Library_Kind use "relocatable"; - for Library_Version use "libdummy.so." & Version; - -end Plib; -@end group -@end smallexample - -@noindent -Directory @file{lib_dir} will contain the internal library file whose name -will be @file{libdummy.so.1}, and @file{libdummy.so} will be a symbolic link to -@file{libdummy.so.1}. - -When @command{gnatmake} detects that a project file -is a library project file, it will check all immediate sources of the project -and rebuild the library if any of the sources have been recompiled. - -Standard project files can import library project files. In such cases, -the libraries will only be rebuilt if some of its sources are recompiled -because they are in the closure of some other source in an importing project. -Sources of the library project files that are not in such a closure will -not be checked, unless the full library is checked, because one of its sources -needs to be recompiled. - -For instance, assume the project file @code{A} imports the library project file -@code{L}. The immediate sources of A are @file{a1.adb}, @file{a2.ads} and -@file{a2.adb}. The immediate sources of L are @file{l1.ads}, @file{l1.adb}, -@file{l2.ads}, @file{l2.adb}. - -If @file{l1.adb} has been modified, then the library associated with @code{L} -will be rebuilt when compiling all the immediate sources of @code{A} only -if @file{a1.ads}, @file{a2.ads} or @file{a2.adb} includes a statement -@code{"with L1;"}. - -To be sure that all the sources in the library associated with @code{L} are -up to date, and that all the sources of project @code{A} are also up to date, -the following two commands needs to be used: - -@smallexample -gnatmake -Pl.gpr -gnatmake -Pa.gpr -@end smallexample - -When a library is built or rebuilt, an attempt is made first to delete all -files in the library directory. -All @file{ALI} files will also be copied from the object directory to the -library directory. To build executables, @command{gnatmake} will use the -library rather than the individual object files. - -@ifclear vms -It is also possible to create library project files for third-party libraries -that are precompiled and cannot be compiled locally thanks to the -@code{externally_built} attribute. (See @ref{Installing a library}). -@end ifclear - -@c ******************************* -@c * Stand-alone Library Projects * -@c ******************************* - -@node Stand-alone Library Projects -@section Stand-alone Library Projects - -@noindent -A Stand-alone Library is a library that contains the necessary code to -elaborate the Ada units that are included in the library. A Stand-alone -Library is suitable to be used in an executable when the main is not -in Ada. However, Stand-alone Libraries may also be used with an Ada main -subprogram. - -A Stand-alone Library Project is a Library Project where the library is -a Stand-alone Library. - -To be a Stand-alone Library Project, in addition to the two attributes -that make a project a Library Project (@code{Library_Name} and -@code{Library_Dir}, see @ref{Library Projects}), the attribute -@code{Library_Interface} must be defined. - -@smallexample @c projectfile -@group - for Library_Dir use "lib_dir"; - for Library_Name use "dummy"; - for Library_Interface use ("int1", "int1.child"); -@end group -@end smallexample - -Attribute @code{Library_Interface} has a nonempty string list value, -each string in the list designating a unit contained in an immediate source -of the project file. - -When a Stand-alone Library is built, first the binder is invoked to build -a package whose name depends on the library name -(^b~dummy.ads/b^B$DUMMY.ADS/B^ in the example above). -This binder-generated package includes initialization and -finalization procedures whose -names depend on the library name (dummyinit and dummyfinal in the example -above). The object corresponding to this package is included in the library. - -A dynamic or relocatable Stand-alone Library is automatically initialized -if automatic initialization of Stand-alone Libraries is supported on the -platform and if attribute @code{Library_Auto_Init} is not specified or -is specified with the value "true". A static Stand-alone Library is never -automatically initialized. - -Single string attribute @code{Library_Auto_Init} may be specified with only -two possible values: "false" or "true" (case-insensitive). Specifying -"false" for attribute @code{Library_Auto_Init} will prevent automatic -initialization of dynamic or relocatable libraries. - -When a non-automatically initialized Stand-alone Library is used -in an executable, its initialization procedure must be called before -any service of the library is used. -When the main subprogram is in Ada, it may mean that the initialization -procedure has to be called during elaboration of another package. - -For a Stand-Alone Library, only the @file{ALI} files of the Interface Units -(those that are listed in attribute @code{Library_Interface}) are copied to -the Library Directory. As a consequence, only the Interface Units may be -imported from Ada units outside of the library. If other units are imported, -the binding phase will fail. - -When a Stand-Alone Library is bound, the switches that are specified in -the attribute @code{Default_Switches ("Ada")} in package @code{Binder} are -used in the call to @command{gnatbind}. - -The string list attribute @code{Library_Options} may be used to specified -additional switches to the call to @command{gcc} to link the library. - -The attribute @code{Library_Src_Dir}, may be specified for a -Stand-Alone Library. @code{Library_Src_Dir} is a simple attribute that has a -single string value. Its value must be the path (absolute or relative to the -project directory) of an existing directory. This directory cannot be the -object directory or one of the source directories, but it can be the same as -the library directory. The sources of the Interface -Units of the library, necessary to an Ada client of the library, will be -copied to the designated directory, called Interface Copy directory. -These sources includes the specs of the Interface Units, but they may also -include bodies and subunits, when pragmas @code{Inline} or @code{Inline_Always} -are used, or when there is a generic units in the spec. Before the sources -are copied to the Interface Copy directory, an attempt is made to delete all -files in the Interface Copy directory. - -@c ************************************* -@c * Switches Related to Project Files * -@c ************************************* -@node Switches Related to Project Files -@section Switches Related to Project Files - -@noindent -The following switches are used by GNAT tools that support project files: - -@table @option - -@item ^-P^/PROJECT_FILE=^@var{project} -@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) -Indicates the name of a project file. This project file will be parsed with -the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, -if any, and using the external references indicated -by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. -@ifclear vms -There may zero, one or more spaces between @option{-P} and @var{project}. -@end ifclear - -@noindent -There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. - -@noindent -Since the Project Manager parses the project file only after all the switches -on the command line are checked, the order of the switches -@option{^-P^/PROJECT_FILE^}, -@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} -or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. - -@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} -@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) -Indicates that external variable @var{name} has the value @var{value}. -The Project Manager will use this value for occurrences of -@code{external(name)} when parsing the project file. - -@ifclear vms -@noindent -If @var{name} or @var{value} includes a space, then @var{name=value} should be -put between quotes. -@smallexample - -XOS=NT - -X"user=John Doe" -@end smallexample -@end ifclear - -@noindent -Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. -If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same -@var{name}, only the last one is used. - -@noindent -An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch -takes precedence over the value of the same name in the environment. - -@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} -@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) -Indicates the verbosity of the parsing of GNAT project files. - -@ifclear vms -@option{-vP0} means Default; -@option{-vP1} means Medium; -@option{-vP2} means High. -@end ifclear - -@ifset vms -There are three possible options for this qualifier: DEFAULT, MEDIUM and -HIGH. -@end ifset - -@noindent -The default is ^Default^DEFAULT^: no output for syntactically correct -project files. -@noindent -If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, -only the last one is used. - -@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^<dir> -@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) -Add directory <dir> at the beginning of the project search path, in order, -after the current working directory. - -@ifclear vms -@item -eL -@cindex @option{-eL} (any project-aware tool) -Follow all symbolic links when processing project files. -@end ifclear - -@item ^--subdirs^/SUBDIRS^=<subdir> -@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) -This switch is recognized by gnatmake and gnatclean. It indicate that the real -directories (except the source directories) are the subdirectories <subdir> -of the directories specified in the project files. This applies in particular -to object directories, library directories and exec directories. If the -subdirectories do not exist, they are created automatically. - -@end table - -@c ********************************** -@c * Tools Supporting Project Files * -@c ********************************** - -@node Tools Supporting Project Files -@section Tools Supporting Project Files - -@menu -* gnatmake and Project Files:: -* The GNAT Driver and Project Files:: -@end menu - -@node gnatmake and Project Files -@subsection gnatmake and Project Files - -@noindent -This section covers several topics related to @command{gnatmake} and -project files: defining ^switches^switches^ for @command{gnatmake} -and for the tools that it invokes; specifying configuration pragmas; -the use of the @code{Main} attribute; building and rebuilding library project -files. - -@menu -* ^Switches^Switches^ and Project Files:: -* Specifying Configuration Pragmas:: -* Project Files and Main Subprograms:: -* Library Project Files:: -@end menu - -@node ^Switches^Switches^ and Project Files -@subsubsection ^Switches^Switches^ and Project Files - -@ifset vms -It is not currently possible to specify VMS style qualifiers in the project -files; only Unix style ^switches^switches^ may be specified. -@end ifset - -@noindent -For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and -@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} -attribute, a @code{^Switches^Switches^} attribute, or both; -as their names imply, these ^switch^switch^-related -attributes affect the ^switches^switches^ that are used for each of these GNAT -components when -@command{gnatmake} is invoked. As will be explained below, these -component-specific ^switches^switches^ precede -the ^switches^switches^ provided on the @command{gnatmake} command line. - -The @code{^Default_Switches^Default_Switches^} attribute is an associative -array indexed by language name (case insensitive) whose value is a string list. -For example: - -@smallexample @c projectfile -@group -package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnaty^-gnaty^", - "^-v^-v^"); -end Compiler; -@end group -@end smallexample - -@noindent -The @code{^Switches^Switches^} attribute is also an associative array, -indexed by a file name (which may or may not be case sensitive, depending -on the operating system) whose value is a string list. For example: - -@smallexample @c projectfile -@group -package Builder is - for ^Switches^Switches^ ("main1.adb") - use ("^-O2^-O2^"); - for ^Switches^Switches^ ("main2.adb") - use ("^-g^-g^"); -end Builder; -@end group -@end smallexample - -@noindent -For the @code{Builder} package, the file names must designate source files -for main subprograms. For the @code{Binder} and @code{Linker} packages, the -file names must designate @file{ALI} or source files for main subprograms. -In each case just the file name without an explicit extension is acceptable. - -For each tool used in a program build (@command{gnatmake}, the compiler, the -binder, and the linker), the corresponding package @dfn{contributes} a set of -^switches^switches^ for each file on which the tool is invoked, based on the -^switch^switch^-related attributes defined in the package. -In particular, the ^switches^switches^ -that each of these packages contributes for a given file @var{f} comprise: - -@itemize @bullet -@item -the value of attribute @code{^Switches^Switches^ (@var{f})}, -if it is specified in the package for the given file, -@item -otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, -if it is specified in the package. -@end itemize - -@noindent -If neither of these attributes is defined in the package, then the package does -not contribute any ^switches^switches^ for the given file. - -When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise -two sets, in the following order: those contributed for the file -by the @code{Builder} package; -and the switches passed on the command line. - -When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, -the ^switches^switches^ passed to the tool comprise three sets, -in the following order: - -@enumerate -@item -the applicable ^switches^switches^ contributed for the file -by the @code{Builder} package in the project file supplied on the command line; - -@item -those contributed for the file by the package (in the relevant project file -- -see below) corresponding to the tool; and - -@item -the applicable switches passed on the command line. -@end enumerate - -@noindent -The term @emph{applicable ^switches^switches^} reflects the fact that -@command{gnatmake} ^switches^switches^ may or may not be passed to individual -tools, depending on the individual ^switch^switch^. - -@command{gnatmake} may invoke the compiler on source files from different -projects. The Project Manager will use the appropriate project file to -determine the @code{Compiler} package for each source file being compiled. -Likewise for the @code{Binder} and @code{Linker} packages. -As an example, consider the following package in a project file: - -@smallexample @c projectfile -@group -project Proj1 is - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for ^Switches^Switches^ ("a.adb") - use ("^-O1^-O1^"); - for ^Switches^Switches^ ("b.adb") - use ("^-O2^-O2^", - "^-gnaty^-gnaty^"); - end Compiler; -end Proj1; -@end group -@end smallexample - -@noindent -If @command{gnatmake} is invoked with this project file, and it needs to -compile, say, the files @file{a.adb}, @file{b.adb}, and @file{c.adb}, then -@file{a.adb} will be compiled with the ^switch^switch^ -@option{^-O1^-O1^}, -@file{b.adb} with ^switches^switches^ -@option{^-O2^-O2^} -and @option{^-gnaty^-gnaty^}, -and @file{c.adb} with @option{^-g^-g^}. - -The following example illustrates the ordering of the ^switches^switches^ -contributed by different packages: - -@smallexample @c projectfile -@group -project Proj2 is - package Builder is - for ^Switches^Switches^ ("main.adb") - use ("^-g^-g^", - "^-O1^-)1^", - "^-f^-f^"); - end Builder; -@end group - -@group - package Compiler is - for ^Switches^Switches^ ("main.adb") - use ("^-O2^-O2^"); - end Compiler; -end Proj2; -@end group -@end smallexample - -@noindent -If you issue the command: - -@smallexample - gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main -@end smallexample - -@noindent -then the compiler will be invoked on @file{main.adb} with the following -sequence of ^switches^switches^ +@c ------ macros for projects.texi +@c These macros are needed when building the gprbuild documentation, but +@c should have no effect in the gnat user's guide +@macro CODESAMPLE{TXT} @smallexample - ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ -@end smallexample - -with the last @option{^-O^-O^} -^switch^switch^ having precedence over the earlier ones; -several other ^switches^switches^ -(such as @option{^-c^-c^}) are added implicitly. - -The ^switches^switches^ -@option{^-g^-g^} -and @option{^-O1^-O1^} are contributed by package -@code{Builder}, @option{^-O2^-O2^} is contributed -by the package @code{Compiler} -and @option{^-O0^-O0^} comes from the command line. - -The @option{^-g^-g^} -^switch^switch^ will also be passed in the invocation of -@command{Gnatlink.} - -A final example illustrates switch contributions from packages in different -project files: - -@smallexample @c projectfile -@group -project Proj3 is - for Source_Files use ("pack.ads", "pack.adb"); - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnata^-gnata^"); - end Compiler; -end Proj3; -@end group - -@group -with "Proj3"; -project Proj4 is - for Source_Files use ("foo_main.adb", "bar_main.adb"); - package Builder is - for ^Switches^Switches^ ("foo_main.adb") - use ("^-s^-s^", - "^-g^-g^"); - end Builder; -end Proj4; -@end group - -@group --- Ada source file: -with Pack; -procedure Foo_Main is - @dots{} -end Foo_Main; -@end group -@end smallexample - -If the command is -@smallexample -gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato -@end smallexample - -@noindent -then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are -@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and -@option{^-gnato^-gnato^} (passed on the command line). -When the imported package @code{Pack} is compiled, the ^switches^switches^ used -are @option{^-g^-g^} from @code{Proj4.Builder}, -@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, -and @option{^-gnato^-gnato^} from the command line. - -@noindent -When using @command{gnatmake} with project files, some ^switches^switches^ or -arguments may be expressed as relative paths. As the working directory where -compilation occurs may change, these relative paths are converted to absolute -paths. For the ^switches^switches^ found in a project file, the relative paths -are relative to the project file directory, for the switches on the command -line, they are relative to the directory where @command{gnatmake} is invoked. -The ^switches^switches^ for which this occurs are: -^-I^-I^, -^-A^-A^, -^-L^-L^, -^-aO^-aO^, -^-aL^-aL^, -^-aI^-aI^, as well as all arguments that are not switches (arguments to -^switch^switch^ -^-o^-o^, object files specified in package @code{Linker} or after --largs on the command line). The exception to this rule is the ^switch^switch^ -^--RTS=^--RTS=^ for which a relative path argument is never converted. - -@node Specifying Configuration Pragmas -@subsubsection Specifying Configuration Pragmas - -When using @command{gnatmake} with project files, if there exists a file -@file{gnat.adc} that contains configuration pragmas, this file will be -ignored. - -Configuration pragmas can be defined by means of the following attributes in -project files: @code{Global_Configuration_Pragmas} in package @code{Builder} -and @code{Local_Configuration_Pragmas} in package @code{Compiler}. - -Both these attributes are single string attributes. Their values is the path -name of a file containing configuration pragmas. If a path name is relative, -then it is relative to the project directory of the project file where the -attribute is defined. - -When compiling a source, the configuration pragmas used are, in order, -those listed in the file designated by attribute -@code{Global_Configuration_Pragmas} in package @code{Builder} of the main -project file, if it is specified, and those listed in the file designated by -attribute @code{Local_Configuration_Pragmas} in package @code{Compiler} of -the project file of the source, if it exists. - -@node Project Files and Main Subprograms -@subsubsection Project Files and Main Subprograms - -@noindent -When using a project file, you can invoke @command{gnatmake} -with one or several main subprograms, by specifying their source files on the -command line. - -@smallexample - gnatmake ^-P^/PROJECT_FILE=^prj main1 main2 main3 -@end smallexample - -@noindent -Each of these needs to be a source file of the same project, except -when the switch ^-u^/UNIQUE^ is used. - -@noindent -When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the -same project, one of the project in the tree rooted at the project specified -on the command line. The package @code{Builder} of this common project, the -"main project" is the one that is considered by @command{gnatmake}. - -@noindent -When ^-u^/UNIQUE^ is used, the specified source files may be in projects -imported directly or indirectly by the project specified on the command line. -Note that if such a source file is not part of the project specified on the -command line, the ^switches^switches^ found in package @code{Builder} of the -project specified on the command line, if any, that are transmitted -to the compiler will still be used, not those found in the project file of -the source file. - -@noindent -When using a project file, you can also invoke @command{gnatmake} without -explicitly specifying any main, and the effect depends on whether you have -defined the @code{Main} attribute. This attribute has a string list value, -where each element in the list is the name of a source file (the file -extension is optional) that contains a unit that can be a main subprogram. - -If the @code{Main} attribute is defined in a project file as a non-empty -string list and the switch @option{^-u^/UNIQUE^} is not used on the command -line, then invoking @command{gnatmake} with this project file but without any -main on the command line is equivalent to invoking @command{gnatmake} with all -the file names in the @code{Main} attribute on the command line. - -Example: -@smallexample @c projectfile @group - project Prj is - for Main use ("main1", "main2", "main3"); - end Prj; -@end group -@end smallexample - -@noindent -With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} -is equivalent to -@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1 main2 main3"}. - -When the project attribute @code{Main} is not specified, or is specified -as an empty string list, or when the switch @option{-u} is used on the command -line, then invoking @command{gnatmake} with no main on the command line will -result in all immediate sources of the project file being checked, and -potentially recompiled. Depending on the presence of the switch @option{-u}, -sources from other project files on which the immediate sources of the main -project file depend are also checked and potentially recompiled. In other -words, the @option{-u} switch is applied to all of the immediate sources of the -main project file. - -When no main is specified on the command line and attribute @code{Main} exists -and includes several mains, or when several mains are specified on the -command line, the default ^switches^switches^ in package @code{Builder} will -be used for all mains, even if there are specific ^switches^switches^ -specified for one or several mains. - -But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be -the specific ^switches^switches^ for each main, if they are specified. - -@node Library Project Files -@subsubsection Library Project Files - -@noindent -When @command{gnatmake} is invoked with a main project file that is a library -project file, it is not allowed to specify one or more mains on the command -line. - -@noindent -When a library project file is specified, switches ^-b^/ACTION=BIND^ and -^-l^/ACTION=LINK^ have special meanings. - -@itemize @bullet -@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates -to @command{gnatmake} that @command{gnatbind} should be invoked for the -library. - -@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates -to @command{gnatmake} that the binder generated file should be compiled -(in the case of a stand-alone library) and that the library should be built. - -@end itemize - -@node The GNAT Driver and Project Files -@subsection The GNAT Driver and Project Files - -@noindent -A number of GNAT tools, other than @command{^gnatmake^gnatmake^} -can benefit from project files: -(@command{^gnatbind^gnatbind^}, -@command{^gnatcheck^gnatcheck^}, -@command{^gnatclean^gnatclean^}, -@command{^gnatelim^gnatelim^}, -@command{^gnatfind^gnatfind^}, -@command{^gnatlink^gnatlink^}, -@command{^gnatls^gnatls^}, -@command{^gnatmetric^gnatmetric^}, -@command{^gnatpp^gnatpp^}, -@command{^gnatstub^gnatstub^}, -and @command{^gnatxref^gnatxref^}). However, none of these tools can be invoked -directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). -They must be invoked through the @command{gnat} driver. - -The @command{gnat} driver is a wrapper that accepts a number of commands and -calls the corresponding tool. It was designed initially for VMS platforms (to -convert VMS qualifiers to Unix-style switches), but it is now available on all -GNAT platforms. - -On non-VMS platforms, the @command{gnat} driver accepts the following commands -(case insensitive): - -@itemize @bullet -@item -BIND to invoke @command{^gnatbind^gnatbind^} -@item -CHOP to invoke @command{^gnatchop^gnatchop^} -@item -CLEAN to invoke @command{^gnatclean^gnatclean^} -@item -COMP or COMPILE to invoke the compiler -@item -ELIM to invoke @command{^gnatelim^gnatelim^} -@item -FIND to invoke @command{^gnatfind^gnatfind^} -@item -KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} -@item -LINK to invoke @command{^gnatlink^gnatlink^} -@item -LS or LIST to invoke @command{^gnatls^gnatls^} -@item -MAKE to invoke @command{^gnatmake^gnatmake^} -@item -NAME to invoke @command{^gnatname^gnatname^} -@item -PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} -@item -PP or PRETTY to invoke @command{^gnatpp^gnatpp^} -@item -METRIC to invoke @command{^gnatmetric^gnatmetric^} -@item -STUB to invoke @command{^gnatstub^gnatstub^} -@item -XREF to invoke @command{^gnatxref^gnatxref^} -@end itemize - -@noindent -(note that the compiler is invoked using the command -@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). - -@noindent -On non-VMS platforms, between @command{gnat} and the command, two -special switches may be used: - -@itemize @bullet -@item -@command{-v} to display the invocation of the tool. -@item -@command{-dn} to prevent the @command{gnat} driver from removing -the temporary files it has created. These temporary files are -configuration files and temporary file list files. -@end itemize - -@noindent -The command may be followed by switches and arguments for the invoked -tool. - -@smallexample - gnat bind -C main.ali - gnat ls -a main - gnat chop foo.txt -@end smallexample - -@noindent -Switches may also be put in text files, one switch per line, and the text -files may be specified with their path name preceded by '@@'. - -@smallexample - gnat bind @@args.txt main.ali -@end smallexample - -@noindent -In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, -METRIC, PP or PRETTY, STUB and XREF, the project file related switches -(@option{^-P^/PROJECT_FILE^}, -@option{^-X^/EXTERNAL_REFERENCE^} and -@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to -the switches of the invoking tool. - -@noindent -When GNAT PP or GNAT PRETTY is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all -the immediate sources of the specified project file. - -@noindent -When GNAT METRIC is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} -with all the immediate sources of the specified project file and with -@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory -of the project. - -@noindent -In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with -a project file, no source is specified on the command line and -switch ^-U^/ALL_PROJECTS^ is specified on the command line, then -the underlying tool (^gnatpp^gnatpp^ or -^gnatmetric^gnatmetric^) is invoked for all sources of all projects, -not only for the immediate sources of the main project. -@ifclear vms -(-U stands for Universal or Union of the project files of the project tree) -@end ifclear - -@noindent -For each of the following commands, there is optionally a corresponding -package in the main project. - -@itemize @bullet -@item -package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) - -@item -package @code{Check} for command CHECK (invoking -@code{^gnatcheck^gnatcheck^}) - -@item -package @code{Compiler} for command COMP or COMPILE (invoking the compiler) - -@item -package @code{Cross_Reference} for command XREF (invoking -@code{^gnatxref^gnatxref^}) - -@item -package @code{Eliminate} for command ELIM (invoking -@code{^gnatelim^gnatelim^}) - -@item -package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) - -@item -package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) - -@item -package @code{Gnatstub} for command STUB -(invoking @code{^gnatstub^gnatstub^}) - -@item -package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) - -@item -package @code{Check} for command CHECK -(invoking @code{^gnatcheck^gnatcheck^}) - -@item -package @code{Metrics} for command METRIC -(invoking @code{^gnatmetric^gnatmetric^}) - -@item -package @code{Pretty_Printer} for command PP or PRETTY -(invoking @code{^gnatpp^gnatpp^}) - -@end itemize - -@noindent -Package @code{Gnatls} has a unique attribute @code{^Switches^Switches^}, -a simple variable with a string list value. It contains ^switches^switches^ -for the invocation of @code{^gnatls^gnatls^}. - -@smallexample @c projectfile -@group -project Proj1 is - package gnatls is - for ^Switches^Switches^ - use ("^-a^-a^", - "^-v^-v^"); - end gnatls; -end Proj1; -@end group -@end smallexample - -@noindent -All other packages have two attribute @code{^Switches^Switches^} and -@code{^Default_Switches^Default_Switches^}. - -@noindent -@code{^Switches^Switches^} is an associative array attribute, indexed by the -source file name, that has a string list value: the ^switches^switches^ to be -used when the tool corresponding to the package is invoked for the specific -source file. - -@noindent -@code{^Default_Switches^Default_Switches^} is an associative array attribute, -indexed by the programming language that has a string list value. -@code{^Default_Switches^Default_Switches^ ("Ada")} contains the -^switches^switches^ for the invocation of the tool corresponding -to the package, except if a specific @code{^Switches^Switches^} attribute -is specified for the source file. - -@smallexample @c projectfile -@group -project Proj is - - for Source_Dirs use ("./**"); - - package gnatls is - for ^Switches^Switches^ use - ("^-a^-a^", - "^-v^-v^"); - end gnatls; -@end group -@group - - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnatv^-gnatv^", - "^-gnatwa^-gnatwa^"); - end Binder; -@end group -@group - - package Binder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^", - "^-e^-e^"); - end Binder; -@end group -@group - - package Linker is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^"); - for ^Switches^Switches^ ("main.adb") - use ("^-C^-C^", - "^-v^-v^", - "^-v^-v^"); - end Linker; -@end group -@group - - package Finder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^"); - end Finder; -@end group -@group - - package Cross_Reference is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^", - "^-d^-d^", - "^-u^-u^"); - end Cross_Reference; -end Proj; -@end group -@end smallexample - -@noindent -With the above project file, commands such as - -@smallexample - ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ - ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ - ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ - ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ - ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ -@end smallexample - -@noindent -will set up the environment properly and invoke the tool with the switches -found in the package corresponding to the tool: -@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, -except @code{^Switches^Switches^ ("main.adb")} -for @code{^gnatlink^gnatlink^}. -It is also possible to invoke some of the tools, -(@code{^gnatcheck^gnatcheck^}, -@code{^gnatmetric^gnatmetric^}, -and @code{^gnatpp^gnatpp^}) -on a set of project units thanks to the combination of the switches -@option{-P}, @option{-U} and possibly the main unit when one is interested -in its closure. For instance, -@smallexample -gnat metric -Pproj -@end smallexample -will compute the metrics for all the immediate units of project -@code{proj}. -@smallexample -gnat metric -Pproj -U -@end smallexample -will compute the metrics for all the units of the closure of projects -rooted at @code{proj}. -@smallexample -gnat metric -Pproj -U main_unit -@end smallexample -will compute the metrics for the closure of units rooted at -@code{main_unit}. This last possibility relies implicitly -on @command{gnatbind}'s option @option{-R}. But if the argument files for the -tool invoked by the the @command{gnat} driver are explicitly specified -either directly or through the tool @option{-files} option, then the tool -is called only for these explicitly specified files. - -@c ********************** -@node An Extended Example -@section An Extended Example - -@noindent -Suppose that we have two programs, @var{prog1} and @var{prog2}, -whose sources are in corresponding directories. We would like -to build them with a single @command{gnatmake} command, and we want to place -their object files into @file{build} subdirectories of the source directories. -Furthermore, we want to have to have two separate subdirectories -in @file{build} -- @file{release} and @file{debug} -- which will contain -the object files compiled with different set of compilation flags. - -In other words, we have the following structure: - -@smallexample -@group - main - |- prog1 - | |- build - | | debug - | | release - |- prog2 - |- build - | debug - | release -@end group -@end smallexample - -@noindent -Here are the project files that we must place in a directory @file{main} -to maintain this structure: - -@enumerate - -@item We create a @code{Common} project with a package @code{Compiler} that -specifies the compilation ^switches^switches^: - -@smallexample -File "common.gpr": -@group -@b{project} Common @b{is} - - @b{for} Source_Dirs @b{use} (); -- No source files -@end group - -@group - @b{type} Build_Type @b{is} ("release", "debug"); - Build : Build_Type := External ("BUILD", "debug"); -@end group -@group - @b{package} Compiler @b{is} - @b{case} Build @b{is} - @b{when} "release" => - @b{for} ^Default_Switches^Default_Switches^ ("Ada") - @b{use} ("^-O2^-O2^"); - @b{when} "debug" => - @b{for} ^Default_Switches^Default_Switches^ ("Ada") - @b{use} ("^-g^-g^"); - @b{end case}; - @b{end} Compiler; - -@b{end} Common; -@end group -@end smallexample - -@item We create separate projects for the two programs: - -@smallexample -@group -File "prog1.gpr": - -@b{with} "common"; -@b{project} Prog1 @b{is} - - @b{for} Source_Dirs @b{use} ("prog1"); - @b{for} Object_Dir @b{use} "prog1/build/" & Common.Build; - - @b{package} Compiler @b{renames} Common.Compiler; - -@b{end} Prog1; -@end group -@end smallexample - -@smallexample -@group -File "prog2.gpr": - -@b{with} "common"; -@b{project} Prog2 @b{is} - - @b{for} Source_Dirs @b{use} ("prog2"); - @b{for} Object_Dir @b{use} "prog2/build/" & Common.Build; - - @b{package} Compiler @b{renames} Common.Compiler; - -@end group -@b{end} Prog2; -@end smallexample - -@item We create a wrapping project @code{Main}: - -@smallexample -@group -File "main.gpr": - -@b{with} "common"; -@b{with} "prog1"; -@b{with} "prog2"; -@b{project} Main @b{is} - - @b{package} Compiler @b{renames} Common.Compiler; - -@b{end} Main; +\TXT\ @end group @end smallexample +@end macro -@item Finally we need to create a dummy procedure that @code{with}s (either -explicitly or implicitly) all the sources of our two programs. +@macro PROJECTFILE{TXT} +@CODESAMPLE{\TXT\} +@end macro -@end enumerate +@c simulates a newline when in a @CODESAMPLE +@macro NL{} +@end macro +@macro TIP{TXT} +@quotation @noindent -Now we can build the programs using the command +\TXT\ +@end quotation +@end macro -@smallexample - gnatmake ^-P^/PROJECT_FILE=^main dummy -@end smallexample +@macro TIPHTML{TXT} +\TXT\ +@end macro +@macro IMPORTANT{TXT} +@quotation @noindent -for the Debug mode, or +\TXT\ +@end quotation -@ifclear vms -@smallexample - gnatmake -Pmain -XBUILD=release -@end smallexample -@end ifclear - -@ifset vms -@smallexample - GNAT MAKE /PROJECT_FILE=main /EXTERNAL_REFERENCE=BUILD=release -@end smallexample -@end ifset +@end macro +@macro NOTE{TXT} +@quotation @noindent -for the Release mode. - -@c ******************************** -@c * Project File Complete Syntax * -@c ******************************** - -@node Project File Complete Syntax -@section Project File Complete Syntax - -@smallexample -project ::= - context_clause project_declaration - -context_clause ::= - @{with_clause@} - -with_clause ::= - @b{with} path_name @{ , path_name @} ; - -path_name ::= - string_literal - -project_declaration ::= - simple_project_declaration | project_extension - -simple_project_declaration ::= - @b{project} <project_>simple_name @b{is} - @{declarative_item@} - @b{end} <project_>simple_name; - -project_extension ::= - @b{project} <project_>simple_name @b{extends} path_name @b{is} - @{declarative_item@} - @b{end} <project_>simple_name; - -declarative_item ::= - package_declaration | - typed_string_declaration | - other_declarative_item - -package_declaration ::= - package_spec | package_renaming - -package_spec ::= - @b{package} package_identifier @b{is} - @{simple_declarative_item@} - @b{end} package_identifier ; - -package_identifier ::= - @code{Naming} | @code{Builder} | @code{Compiler} | @code{Binder} | - @code{Linker} | @code{Finder} | @code{Cross_Reference} | - @code{^gnatls^gnatls^} | @code{IDE} | @code{Pretty_Printer} - -package_renaming ::== - @b{package} package_identifier @b{renames} - <project_>simple_name.package_identifier ; - -typed_string_declaration ::= - @b{type} <typed_string_>_simple_name @b{is} - ( string_literal @{, string_literal@} ); - -other_declarative_item ::= - attribute_declaration | - typed_variable_declaration | - variable_declaration | - case_construction - -attribute_declaration ::= - full_associative_array_declaration | - @b{for} attribute_designator @b{use} expression ; - -full_associative_array_declaration ::= - @b{for} <associative_array_attribute_>simple_name @b{use} - <project_>simple_name [ . <package_>simple_Name ] ' <attribute_>simple_name ; - -attribute_designator ::= - <simple_attribute_>simple_name | - <associative_array_attribute_>simple_name ( string_literal ) - -typed_variable_declaration ::= - <typed_variable_>simple_name : <typed_string_>name := string_expression ; - -variable_declaration ::= - <variable_>simple_name := expression; - -expression ::= - term @{& term@} - -term ::= - literal_string | - string_list | - <variable_>name | - external_value | - attribute_reference - -string_literal ::= - (same as Ada) - -string_list ::= - ( <string_>expression @{ , <string_>expression @} ) - -external_value ::= - @b{external} ( string_literal [, string_literal] ) - -attribute_reference ::= - attribute_prefix ' <simple_attribute_>simple_name [ ( literal_string ) ] - -attribute_prefix ::= - @b{project} | - <project_>simple_name | package_identifier | - <project_>simple_name . package_identifier - -case_construction ::= - @b{case} <typed_variable_>name @b{is} - @{case_item@} - @b{end case} ; - -case_item ::= - @b{when} discrete_choice_list => - @{case_construction | attribute_declaration@} - -discrete_choice_list ::= - string_literal @{| string_literal@} | - @b{others} - -name ::= - simple_name @{. simple_name@} +\TXT\ +@end quotation +@end macro -simple_name ::= - identifier (same as Ada) +@include projects.texi -@end smallexample +@c ***************************************** +@c * Cross-referencing tools +@c ***************************************** @node The Cross-Referencing Tools gnatxref and gnatfind @chapter The Cross-Referencing Tools @code{gnatxref} and @code{gnatfind} @@ -15504,6 +11960,13 @@ Do not look for sources in the system default directory. @cindex @option{-nostdlib} (@command{gnatxref}) Do not look for library files in the system default directory. +@item --ext=@var{extension} +@cindex @option{--ext} (@command{gnatxref}) +Specify an alternate ali file extension. The default is @code{ali} and other +extensions (e.g. @code{sli} for SPARK library files) may be specified via this +switch. Note that if this switch overrides the default, which means that only +the new extension will be considered. + @item --RTS=@var{rts-path} @cindex @option{--RTS} (@command{gnatxref}) Specifies the default location of the runtime library. Same meaning as the @@ -15532,7 +11995,7 @@ Equivalent to @samp{-aODIR -aIDIR}. @item -pFILE @cindex @option{-pFILE} (@command{gnatxref}) -Specify a project file to use @xref{Project Files}. +Specify a project file to use @xref{GNAT Project Manager}. If you need to use the @file{.gpr} project files, you should use gnatxref through the GNAT driver (@command{gnat xref -Pproject}). @@ -15715,7 +12178,7 @@ Equivalent to @samp{-aODIR -aIDIR}. @item -pFILE @cindex @option{-pFILE} (@command{gnatfind}) -Specify a project file (@pxref{Project Files}) to use. +Specify a project file (@pxref{GNAT Project Manager}) to use. By default, @code{gnatxref} and @code{gnatfind} will try to locate a project file in the current directory. @@ -18933,6 +15396,15 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. +@item ^--subdirs^/SUBDIRS^=subdir +Actual object directory of each project file is the subdirectory subdir of the +object directory specified or defauted in the project file. + +@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +By default, shared library projects are not allowed to import static library +projects. When this switch is used on the command line, this restriction is +relaxed. + @item ^-c^/COMPILER_FILES_ONLY^ @cindex @option{^-c^/COMPILER_FILES_ONLY^} (@code{gnatclean}) Only attempt to delete the files produced by the compiler, not those produced @@ -19210,46 +15682,7 @@ be accessed by the directive @option{-l@var{xxx}} at link time. @noindent If you use project files, library installation is part of the library build -process. Thus no further action is needed in order to make use of the -libraries that are built as part of the general application build. A usable -version of the library is installed in the directory specified by the -@code{Library_Dir} attribute of the library project file. - -You may want to install a library in a context different from where the library -is built. This situation arises with third party suppliers, who may want -to distribute a library in binary form where the user is not expected to be -able to recompile the library. The simplest option in this case is to provide -a project file slightly different from the one used to build the library, by -using the @code{externally_built} attribute. For instance, the project -file used to build the library in the previous section can be changed into the -following one when the library is installed: - -@smallexample @c projectfile -project My_Lib is - for Source_Dirs use ("src1", "src2"); - for Library_Name use "mylib"; - for Library_Dir use "lib"; - for Library_Kind use "dynamic"; - for Externally_Built use "true"; -end My_lib; -@end smallexample - -@noindent -This project file assumes that the directories @file{src1}, -@file{src2}, and @file{lib} exist in -the directory containing the project file. The @code{externally_built} -attribute makes it clear to the GNAT builder that it should not attempt to -recompile any of the units from this library. It allows the library provider to -restrict the source set to the minimum necessary for clients to make use of the -library as described in the first section of this chapter. It is the -responsibility of the library provider to install the necessary sources, ALI -files and libraries in the directories mentioned in the project file. For -convenience, the user's library project file should be installed in a location -that will be searched automatically by the GNAT -builder. These are the directories referenced in the @env{GPR_PROJECT_PATH} -environment variable (@pxref{Importing Projects}), and also the default GNAT -library location that can be queried with @command{gnatls -v} and is usually of -the form $gnat_install_root/lib/gnat. +process (@pxref{Installing a library with project files}). When project files are not an option, it is also possible, but not recommended, to install the library so that the sources needed to use the library are on the @@ -21192,1808 +17625,13 @@ release. @end ignore @noindent -The following subsections document the rules implemented in -@command{gnatcheck}. -The subsection title is the same as the rule identifier, which may be -used as a parameter of the @option{+R} or @option{-R} options. - - -@menu -* Abstract_Type_Declarations:: -* Anonymous_Arrays:: -* Anonymous_Subtypes:: -* Blocks:: -* Boolean_Relational_Operators:: -@ignore -* Ceiling_Violations:: -@end ignore -* Complex_Inlined_Subprograms:: -* Controlled_Type_Declarations:: -* Declarations_In_Blocks:: -* Deep_Inheritance_Hierarchies:: -* Deeply_Nested_Generics:: -* Deeply_Nested_Inlining:: -@ignore -* Deeply_Nested_Local_Inlining:: -@end ignore -* Default_Parameters:: -* Direct_Calls_To_Primitives:: -* Discriminated_Records:: -* Enumeration_Ranges_In_CASE_Statements:: -* Exceptions_As_Control_Flow:: -* Exits_From_Conditional_Loops:: -* EXIT_Statements_With_No_Loop_Name:: -* Expanded_Loop_Exit_Names:: -* Explicit_Full_Discrete_Ranges:: -* Float_Equality_Checks:: -* Forbidden_Attributes:: -* Forbidden_Pragmas:: -* Function_Style_Procedures:: -* Generics_In_Subprograms:: -* GOTO_Statements:: -* Implicit_IN_Mode_Parameters:: -* Implicit_SMALL_For_Fixed_Point_Types:: -* Improperly_Located_Instantiations:: -* Improper_Returns:: -* Library_Level_Subprograms:: -* Local_Packages:: -@ignore -* Improperly_Called_Protected_Entries:: -@end ignore -* Metrics:: -* Misnamed_Controlling_Parameters:: -* Misnamed_Identifiers:: -* Multiple_Entries_In_Protected_Definitions:: -* Name_Clashes:: -* Non_Qualified_Aggregates:: -* Non_Short_Circuit_Operators:: -* Non_SPARK_Attributes:: -* Non_Tagged_Derived_Types:: -* Non_Visible_Exceptions:: -* Numeric_Literals:: -* OTHERS_In_Aggregates:: -* OTHERS_In_CASE_Statements:: -* OTHERS_In_Exception_Handlers:: -* Outer_Loop_Exits:: -* Overloaded_Operators:: -* Overly_Nested_Control_Structures:: -* Parameters_Out_Of_Order:: -* Positional_Actuals_For_Defaulted_Generic_Parameters:: -* Positional_Actuals_For_Defaulted_Parameters:: -* Positional_Components:: -* Positional_Generic_Parameters:: -* Positional_Parameters:: -* Predefined_Numeric_Types:: -* Raising_External_Exceptions:: -* Raising_Predefined_Exceptions:: -* Separate_Numeric_Error_Handlers:: -@ignore -* Recursion:: -* Side_Effect_Functions:: -@end ignore -* Slices:: -* Too_Many_Parents:: -* Unassigned_OUT_Parameters:: -* Uncommented_BEGIN_In_Package_Bodies:: -* Unconditional_Exits:: -* Unconstrained_Array_Returns:: -* Universal_Ranges:: -* Unnamed_Blocks_And_Loops:: -@ignore -* Unused_Subprograms:: -@end ignore -* USE_PACKAGE_Clauses:: -* Visible_Components:: -* Volatile_Objects_Without_Address_Clauses:: -@end menu - - -@node Abstract_Type_Declarations -@subsection @code{Abstract_Type_Declarations} -@cindex @code{Abstract_Type_Declarations} rule (for @command{gnatcheck}) - -@noindent -Flag all declarations of abstract types. For an abstract private -type, both the private and full type declarations are flagged. - -This rule has no parameters. - - -@node Anonymous_Arrays -@subsection @code{Anonymous_Arrays} -@cindex @code{Anonymous_Arrays} rule (for @command{gnatcheck}) - -@noindent -Flag all anonymous array type definitions (by Ada semantics these can only -occur in object declarations). - -This rule has no parameters. - -@node Anonymous_Subtypes -@subsection @code{Anonymous_Subtypes} -@cindex @code{Anonymous_Subtypes} rule (for @command{gnatcheck}) - -@noindent -Flag all uses of anonymous subtypes (except cases when subtype indication -is a part of a record component definition, and this subtype indication -depends on a discriminant). A use of an anonymous subtype is -any instance of a subtype indication with a constraint, other than one -that occurs immediately within a subtype declaration. Any use of a range -other than as a constraint used immediately within a subtype declaration -is considered as an anonymous subtype. - -An effect of this rule is that @code{for} loops such as the following are -flagged (since @code{1..N} is formally a ``range''): - -@smallexample @c ada -for I in 1 .. N loop - @dots{} -end loop; -@end smallexample - -@noindent -Declaring an explicit subtype solves the problem: - -@smallexample @c ada -subtype S is Integer range 1..N; -@dots{} -for I in S loop - @dots{} -end loop; -@end smallexample - -@noindent -This rule has no parameters. - -@node Blocks -@subsection @code{Blocks} -@cindex @code{Blocks} rule (for @command{gnatcheck}) - -@noindent -Flag each block statement. - -This rule has no parameters. - -@node Boolean_Relational_Operators -@subsection @code{Boolean_Relational_Operators} -@cindex @code{Boolean_Relational_Operators} rule (for @command{gnatcheck}) - -@noindent -Flag each call to a predefined relational operator (``<'', ``>'', ``<='', -``>='', ``='' and ``/='') for the predefined Boolean type. -(This rule is useful in enforcing the SPARK language restrictions.) - -Calls to predefined relational operators of any type derived from -@code{Standard.Boolean} are not detected. Calls to user-defined functions -with these designators, and uses of operators that are renamings -of the predefined relational operators for @code{Standard.Boolean}, -are likewise not detected. - -This rule has no parameters. - -@ignore -@node Ceiling_Violations -@subsection @code{Ceiling5_Violations} (under construction, GLOBAL) -@cindex @code{Ceiling_Violations} rule (for @command{gnatcheck}) - -@noindent -Flag invocations of a protected operation by a task whose priority exceeds -the protected object's ceiling. - -As of @value{NOW}, this rule has the following limitations: - -@itemize @bullet - -@item - We consider only pragmas Priority and Interrupt_Priority as means to define - a task/protected operation priority. We do not consider the effect of using - Ada.Dynamic_Priorities.Set_Priority procedure; - -@item - We consider only base task priorities, and no priority inheritance. That is, - we do not make a difference between calls issued during task activation and - execution of the sequence of statements from task body; - -@item - Any situation when the priority of protected operation caller is set by a - dynamic expression (that is, the corresponding Priority or - Interrupt_Priority pragma has a non-static expression as an argument) we - treat as a priority inconsistency (and, therefore, detect this situation). -@end itemize - -@noindent -At the moment the notion of the main subprogram is not implemented in -gnatcheck, so any pragma Priority in a library level subprogram body (in case -if this subprogram can be a main subprogram of a partition) changes the -priority of an environment task. So if we have more then one such pragma in -the set of processed sources, the pragma that is processed last, defines the -priority of an environment task. - -This rule has no parameters. -@end ignore - -@node Controlled_Type_Declarations -@subsection @code{Controlled_Type_Declarations} -@cindex @code{Controlled_Type_Declarations} rule (for @command{gnatcheck}) - -@noindent -Flag all declarations of controlled types. A declaration of a private type -is flagged if its full declaration declares a controlled type. A declaration -of a derived type is flagged if its ancestor type is controlled. Subtype -declarations are not checked. A declaration of a type that itself is not a -descendant of a type declared in @code{Ada.Finalization} but has a controlled -component is not checked. - -This rule has no parameters. - - -@node Complex_Inlined_Subprograms -@subsection @code{Complex_Inlined_Subprograms} -@cindex @code{Complex_Inlined_Subprograms} rule (for @command{gnatcheck}) - -@noindent -Flags a subprogram (or generic subprogram) if -pragma Inline is applied to the subprogram and at least one of the following -conditions is met: - -@itemize @bullet -@item -it contains at least one complex declaration such as a subprogram body, -package, task, protected declaration, or a generic instantiation -(except instantiation of @code{Ada.Unchecked_Conversion}); - -@item -it contains at least one complex statement such as a loop, a case -or a if statement, or a short circuit control form; - -@item -the number of statements exceeds -a value specified by the @option{N} rule parameter; -@end itemize - -@noindent -This rule has the following (mandatory) parameter for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximum allowed total number of statements -in the subprogram body. -@end table - - -@node Declarations_In_Blocks -@subsection @code{Declarations_In_Blocks} -@cindex @code{Declarations_In_Blocks} rule (for @command{gnatcheck}) - -@noindent -Flag all block statements containing local declarations. A @code{declare} -block with an empty @i{declarative_part} or with a @i{declarative part} -containing only pragmas and/or @code{use} clauses is not flagged. - -This rule has no parameters. - - -@node Deep_Inheritance_Hierarchies -@subsection @code{Deep_Inheritance_Hierarchies} -@cindex @code{Deep_Inheritance_Hierarchies} rule (for @command{gnatcheck}) - -@noindent -Flags a tagged derived type declaration or an interface type declaration if -its depth (in its inheritance -hierarchy) exceeds the value specified by the @option{N} rule parameter. - -The inheritance depth of a tagged type or interface type is defined as 0 for -a type with no parent and no progenitor, and otherwise as 1 + max of the -depths of the immediate parent and immediate progenitors. - -This rule does not flag private extension -declarations. In the case of a private extension, the corresponding full -declaration is checked. - -This rule has the following (mandatory) parameter for the @option{+R} option: - -@table @emph -@item N -Integer not less than -1 specifying the maximal allowed depth of any inheritance -hierarchy. If the rule parameter is set to -1, the rule flags all the declarations -of tagged and interface types. -@end table - - -@node Deeply_Nested_Generics -@subsection @code{Deeply_Nested_Generics} -@cindex @code{Deeply_Nested_Generics} rule (for @command{gnatcheck}) - -@noindent -Flags a generic declaration nested in another generic declaration if -the nesting level of the inner generic exceeds -a value specified by the @option{N} rule parameter. -The nesting level is the number of generic declaratons that enclose the given -(generic) declaration. Formal packages are not flagged by this rule. - -This rule has the following (mandatory) parameters for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximal allowed nesting level -for a generic declaration. -@end table - -@node Deeply_Nested_Inlining -@subsection @code{Deeply_Nested_Inlining} -@cindex @code{Deeply_Nested_Inlining} rule (for @command{gnatcheck}) - -@noindent -Flags a subprogram (or generic subprogram) if -pragma Inline has been applied to the subprogram but the subprogram -calls to another inlined subprogram that results in nested inlining -with nesting depth exceeding the value specified by the -@option{N} rule parameter. - -This rule requires the global analysis of all the compilation units that -are @command{gnatcheck} arguments; such analysis may affect the tool's -performance. - -This rule has the following (mandatory) parameter for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximal allowed level of nested inlining. -@end table - - -@ignore -@node Deeply_Nested_Local_Inlining -@subsection @code{Deeply_Nested_Local_Inlining} -@cindex @code{Deeply_Nested_Local_Inlining} rule (for @command{gnatcheck}) - -@noindent -Flags a subprogram body if a pragma @code{Inline} is applied to the -corresponding subprogram (or generic subprogram) and the body contains a call -to another inlined subprogram that results in nested inlining with nesting -depth more then a value specified by the @option{N} rule parameter. -This rule is similar to @code{Deeply_Nested_Inlining} rule, but it -assumes that calls to subprograms in -with'ed units are not inlided, so all the analysis of the depth of inlining is -limited by the compilation unit where the subprogram body is located and the -units it depends semantically upon. Such analysis may be usefull for the case -when neiter @option{-gnatn} nor @option{-gnatN} option is used when building -the executable. - -This rule has the following (mandatory) parameters for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximal allowed level of nested inlining. -@end table - -@end ignore - -@node Default_Parameters -@subsection @code{Default_Parameters} -@cindex @code{Default_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flag all default expressions for subprogram parameters. Parameter -declarations of formal and generic subprograms are also checked. - -This rule has no parameters. - - -@node Direct_Calls_To_Primitives -@subsection @code{Direct_Calls_To_Primitives} -@cindex @code{Direct_Calls_To_Primitives} rule (for @command{gnatcheck}) - -@noindent -Flags any non-dispatching call to a dispatching primitive operation, except -for the common idiom where a primitive subprogram for a tagged type -directly calls the same primitive subprogram of the type's immediate ancestor. - -This rule has no parameters. - - -@node Discriminated_Records -@subsection @code{Discriminated_Records} -@cindex @code{Discriminated_Records} rule (for @command{gnatcheck}) - -@noindent -Flag all declarations of record types with discriminants. Only the -declarations of record and record extension types are checked. Incomplete, -formal, private, derived and private extension type declarations are not -checked. Task and protected type declarations also are not checked. - -This rule has no parameters. - - -@node Enumeration_Ranges_In_CASE_Statements -@subsection @code{Enumeration_Ranges_In_CASE_Statements} -@cindex @code{Enumeration_Ranges_In_CASE_Statements} (for @command{gnatcheck}) - -@noindent -Flag each use of a range of enumeration literals as a choice in a -@code{case} statement. -All forms for specifying a range (explicit ranges -such as @code{A .. B}, subtype marks and @code{'Range} attributes) are flagged. -An enumeration range is -flagged even if contains exactly one enumeration value or no values at all. A -type derived from an enumeration type is considered as an enumeration type. - -This rule helps prevent maintenance problems arising from adding an -enumeration value to a type and having it implicitly handled by an existing -@code{case} statement with an enumeration range that includes the new literal. - -This rule has no parameters. - - -@node Exceptions_As_Control_Flow -@subsection @code{Exceptions_As_Control_Flow} -@cindex @code{Exceptions_As_Control_Flow} (for @command{gnatcheck}) - -@noindent -Flag each place where an exception is explicitly raised and handled in the -same subprogram body. A @code{raise} statement in an exception handler, -package body, task body or entry body is not flagged. - -The rule has no parameters. - -@node Exits_From_Conditional_Loops -@subsection @code{Exits_From_Conditional_Loops} -@cindex @code{Exits_From_Conditional_Loops} (for @command{gnatcheck}) - -@noindent -Flag any exit statement if it transfers the control out of a @code{for} loop -or a @code{while} loop. This includes cases when the @code{exit} statement -applies to a @code{FOR} or @code{while} loop, and cases when it is enclosed -in some @code{for} or @code{while} loop, but transfers the control from some -outer (inconditional) @code{loop} statement. - -The rule has no parameters. - - -@node EXIT_Statements_With_No_Loop_Name -@subsection @code{EXIT_Statements_With_No_Loop_Name} -@cindex @code{EXIT_Statements_With_No_Loop_Name} (for @command{gnatcheck}) - -@noindent -Flag each @code{exit} statement that does not specify the name of the loop -being exited. - -The rule has no parameters. - - -@node Expanded_Loop_Exit_Names -@subsection @code{Expanded_Loop_Exit_Names} -@cindex @code{Expanded_Loop_Exit_Names} rule (for @command{gnatcheck}) - -@noindent -Flag all expanded loop names in @code{exit} statements. - -This rule has no parameters. - -@node Explicit_Full_Discrete_Ranges -@subsection @code{Explicit_Full_Discrete_Ranges} -@cindex @code{Explicit_Full_Discrete_Ranges} rule (for @command{gnatcheck}) - -@noindent -Flag each discrete range that has the form @code{A'First .. A'Last}. - -This rule has no parameters. - -@node Float_Equality_Checks -@subsection @code{Float_Equality_Checks} -@cindex @code{Float_Equality_Checks} rule (for @command{gnatcheck}) - -@noindent -Flag all calls to the predefined equality operations for floating-point types. -Both ``@code{=}'' and ``@code{/=}'' operations are checked. -User-defined equality operations are not flagged, nor are ``@code{=}'' -and ``@code{/=}'' operations for fixed-point types. - -This rule has no parameters. - - -@node Forbidden_Attributes -@subsection @code{Forbidden_Attributes} -@cindex @code{Forbidden_Attributes} rule (for @command{gnatcheck}) - -@noindent -Flag each use of the specified attributes. The attributes to be detected are -named in the rule's parameters. - -This rule has the following parameters: - -@itemize @bullet -@item For the @option{+R} option - -@table @asis -@item @emph{Attribute_Designator} -Adds the specified attribute to the set of attributes to be detected and sets -the detection checks for all the specified attributes ON. -If @emph{Attribute_Designator} -does not denote any attribute defined in the Ada standard -or in -@ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference -Manual}, it is treated as the name of unknown attribute. - -@item @code{GNAT} -All the GNAT-specific attributes are detected; this sets -the detection checks for all the specified attributes ON. - -@item @code{ALL} -All attributes are detected; this sets the rule ON. -@end table - -@item For the @option{-R} option -@table @asis -@item @emph{Attribute_Designator} -Removes the specified attribute from the set of attributes to be -detected without affecting detection checks for -other attributes. If @emph{Attribute_Designator} does not correspond to any -attribute defined in the Ada standard or in -@ref{Implementation Defined Attributes,,, gnat_rm, GNAT Reference Manual}, -this option is treated as turning OFF detection of all unknown attributes. - -@item GNAT -Turn OFF detection of all GNAT-specific attributes - -@item ALL -Clear the list of the attributes to be detected and -turn the rule OFF. -@end table -@end itemize - -@noindent -Parameters are not case sensitive. If @emph{Attribute_Designator} does not -have the syntax of an Ada identifier and therefore can not be considered as a -(part of an) attribute designator, a diagnostic message is generated and the -corresponding parameter is ignored. (If an attribute allows a static -expression to be a part of the attribute designator, this expression is -ignored by this rule.) - -When more then one parameter is given in the same rule option, the parameters -must be separated by commas. - -If more then one option for this rule is specified for the gnatcheck call, a -new option overrides the previous one(s). - -The @option{+R} option with no parameters turns the rule ON, with the set of -attributes to be detected defined by the previous rule options. -(By default this set is empty, so if the only option specified for the rule is -@option{+RForbidden_Attributes} (with -no parameter), then the rule is enabled, but it does not detect anything). -The @option{-R} option with no parameter turns the rule OFF, but it does not -affect the set of attributes to be detected. - - -@node Forbidden_Pragmas -@subsection @code{Forbidden_Pragmas} -@cindex @code{Forbidden_Pragmas} rule (for @command{gnatcheck}) - -@noindent -Flag each use of the specified pragmas. The pragmas to be detected -are named in the rule's parameters. - -This rule has the following parameters: - -@itemize @bullet -@item For the @option{+R} option - -@table @asis -@item @emph{Pragma_Name} -Adds the specified pragma to the set of pragmas to be -checked and sets the checks for all the specified pragmas -ON. @emph{Pragma_Name} is treated as a name of a pragma. If it -does not correspond to any pragma name defined in the Ada -standard or to the name of a GNAT-specific pragma defined -in @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference -Manual}, it is treated as the name of unknown pragma. - -@item @code{GNAT} -All the GNAT-specific pragmas are detected; this sets -the checks for all the specified pragmas ON. - -@item @code{ALL} -All pragmas are detected; this sets the rule ON. -@end table - -@item For the @option{-R} option -@table @asis -@item @emph{Pragma_Name} -Removes the specified pragma from the set of pragmas to be -checked without affecting checks for -other pragmas. @emph{Pragma_Name} is treated as a name -of a pragma. If it does not correspond to any pragma -defined in the Ada standard or to any name defined in -@ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}, -this option is treated as turning OFF detection of all unknown pragmas. - -@item GNAT -Turn OFF detection of all GNAT-specific pragmas - -@item ALL -Clear the list of the pragmas to be detected and -turn the rule OFF. -@end table -@end itemize - -@noindent -Parameters are not case sensitive. If @emph{Pragma_Name} does not have -the syntax of an Ada identifier and therefore can not be considered -as a pragma name, a diagnostic message is generated and the corresponding -parameter is ignored. - -When more then one parameter is given in the same rule option, the parameters -must be separated by a comma. - -If more then one option for this rule is specified for the @command{gnatcheck} -call, a new option overrides the previous one(s). - -The @option{+R} option with no parameters turns the rule ON with the set of -pragmas to be detected defined by the previous rule options. -(By default this set is empty, so if the only option specified for the rule is -@option{+RForbidden_Pragmas} (with -no parameter), then the rule is enabled, but it does not detect anything). -The @option{-R} option with no parameter turns the rule OFF, but it does not -affect the set of pragmas to be detected. - - - - -@node Function_Style_Procedures -@subsection @code{Function_Style_Procedures} -@cindex @code{Function_Style_Procedures} rule (for @command{gnatcheck}) - -@noindent -Flag each procedure that can be rewritten as a function. A procedure can be -converted into a function if it has exactly one parameter of mode @code{out} -and no parameters of mode @code{in out}. Procedure declarations, -formal procedure declarations, and generic procedure declarations are always -checked. Procedure -bodies and body stubs are flagged only if they do not have corresponding -separate declarations. Procedure renamings and procedure instantiations are -not flagged. - -If a procedure can be rewritten as a function, but its @code{out} parameter is -of a limited type, it is not flagged. - -Protected procedures are not flagged. Null procedures also are not flagged. - -This rule has no parameters. - - -@node Generics_In_Subprograms -@subsection @code{Generics_In_Subprograms} -@cindex @code{Generics_In_Subprograms} rule (for @command{gnatcheck}) - -@noindent -Flag each declaration of a generic unit in a subprogram. Generic -declarations in the bodies of generic subprograms are also flagged. -A generic unit nested in another generic unit is not flagged. -If a generic unit is -declared in a local package that is declared in a subprogram body, the -generic unit is flagged. - -This rule has no parameters. - - -@node GOTO_Statements -@subsection @code{GOTO_Statements} -@cindex @code{GOTO_Statements} rule (for @command{gnatcheck}) - -@noindent -Flag each occurrence of a @code{goto} statement. - -This rule has no parameters. - - -@node Implicit_IN_Mode_Parameters -@subsection @code{Implicit_IN_Mode_Parameters} -@cindex @code{Implicit_IN_Mode_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flag each occurrence of a formal parameter with an implicit @code{in} mode. -Note that @code{access} parameters, although they technically behave -like @code{in} parameters, are not flagged. - -This rule has no parameters. - - -@node Implicit_SMALL_For_Fixed_Point_Types -@subsection @code{Implicit_SMALL_For_Fixed_Point_Types} -@cindex @code{Implicit_SMALL_For_Fixed_Point_Types} rule (for @command{gnatcheck}) - -@noindent -Flag each fixed point type declaration that lacks an explicit -representation clause to define its @code{'Small} value. -Since @code{'Small} can be defined only for ordinary fixed point types, -decimal fixed point type declarations are not checked. - -This rule has no parameters. - - -@node Improperly_Located_Instantiations -@subsection @code{Improperly_Located_Instantiations} -@cindex @code{Improperly_Located_Instantiations} rule (for @command{gnatcheck}) - -@noindent -Flag all generic instantiations in library-level package specs -(including library generic packages) and in all subprogram bodies. - -Instantiations in task and entry bodies are not flagged. Instantiations in the -bodies of protected subprograms are flagged. - -This rule has no parameters. - - - -@node Improper_Returns -@subsection @code{Improper_Returns} -@cindex @code{Improper_Returns} rule (for @command{gnatcheck}) - -@noindent -Flag each explicit @code{return} statement in procedures, and -multiple @code{return} statements in functions. -Diagnostic messages are generated for all @code{return} statements -in a procedure (thus each procedure must be written so that it -returns implicitly at the end of its statement part), -and for all @code{return} statements in a function after the first one. -This rule supports the stylistic convention that each subprogram -should have no more than one point of normal return. - -This rule has no parameters. - - -@node Library_Level_Subprograms -@subsection @code{Library_Level_Subprograms} -@cindex @code{Library_Level_Subprograms} rule (for @command{gnatcheck}) - -@noindent -Flag all library-level subprograms (including generic subprogram instantiations). - -This rule has no parameters. - - -@node Local_Packages -@subsection @code{Local_Packages} -@cindex @code{Local_Packages} rule (for @command{gnatcheck}) - -@noindent -Flag all local packages declared in package and generic package -specs. -Local packages in bodies are not flagged. - -This rule has no parameters. - -@ignore -@node Improperly_Called_Protected_Entries -@subsection @code{Improperly_Called_Protected_Entries} (under construction, GLOBAL) -@cindex @code{Improperly_Called_Protected_Entries} rule (for @command{gnatcheck}) - -@noindent -Flag each protected entry that can be called from more than one task. - -This rule has no parameters. -@end ignore - -@node Metrics -@subsection @code{Metrics} -@cindex @code{Metrics} rule (for @command{gnatcheck}) - -@noindent -There is a set of checks based on computing a metric value and comparing the -result with the specified upper (or lower, depending on a specific metric) -value specified for a given metric. A construct is flagged if a given metric -is applicable (can be computed) for it and the computed value is greater -then (lover then) the specified upper (lower) bound. - -The name of any metric-based rule consists of the prefix @code{Metrics_} -followed by the name of the corresponding metric (see the table below). -For @option{+R} option, each metric-based rule has a numeric parameter -specifying the bound (integer or real, depending on a metric), @option{-R} -option for metric rules does not have a parameter. - -The following table shows the metric names for that the corresponding -metrics-based checks are supported by gnatcheck, including the -constraint that must be satisfied by the bound that is specified for the check -and what bound - upper (U) or lower (L) - should be specified. - -@multitable {@code{Cyclomatic_Complexity}}{Cyclomatic complexity}{Positive integer} -@ifnothtml -@headitem Check Name @tab Description @tab Bounds Value -@end ifnothtml -@ifhtml -@item @b{Check Name} @tab @b{Description} @tab @b{Bounds Value} -@end ifhtml -@c Above conditional code is workaround to bug in texi2html (Feb 2008) -@item @code{Essential_Complexity} @tab Essential complexity @tab Positive integer (U) -@item @code{Cyclomatic_Complexity} @tab Cyclomatic complexity @tab Positive integer (U) -@item @code{LSLOC} @tab Logical Source Lines of Code @tab Positive integer (U) -@end multitable - -@noindent -The meaning and the computed values for all these metrics are exactly -the same as for the corresponding metrics in @command{gnatmetric}. - -@emph{Example:} the rule -@smallexample -+RMetrics_Cyclomatic_Complexity : 7 -@end smallexample -@noindent -means that all bodies with cyclomatic complexity exceeding 7 will be flagged. - -To turn OFF the check for cyclomatic complexity metric, use the following option: -@smallexample --RMetrics_Cyclomatic_Complexity -@end smallexample - - -@node Misnamed_Controlling_Parameters -@subsection @code{Misnamed_Controlling_Parameters} -@cindex @code{Misnamed_Controlling_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flags a declaration of a dispatching operation, if the first parameter is -not a controlling one and its name is not @code{This} (the check for -parameter name is not case-sensitive). Declarations of dispatching functions -with controlling result and no controlling parameter are never flagged. - -A subprogram body declaration, subprogram renaming declaration or subprogram -body stub is flagged only if it is not a completion of a prior subprogram -declaration. - -This rule has no parameters. - - - -@node Misnamed_Identifiers -@subsection @code{Misnamed_Identifiers} -@cindex @code{Misnamed_Identifiers} rule (for @command{gnatcheck}) - -@noindent -Flag the declaration of each identifier that does not have a suffix -corresponding to the kind of entity being declared. -The following declarations are checked: - -@itemize @bullet -@item -type declarations - -@item -subtype declarations - -@item -constant declarations (but not number declarations) - -@item -package renaming declarations (but not generic package renaming -declarations) -@end itemize - -@noindent -This rule may have parameters. When used without parameters, the rule enforces -the following checks: - -@itemize @bullet -@item -type-defining names end with @code{_T}, unless the type is an access type, -in which case the suffix must be @code{_A} -@item -constant names end with @code{_C} -@item -names defining package renamings end with @code{_R} -@end itemize - -@noindent -Defining identifiers from incomplete type declarations are never flagged. - -For a private type declaration (including private extensions), the defining -identifier from the private type declaration is checked against the type -suffix (even if the corresponding full declaration is an access type -declaration), and the defining identifier from the corresponding full type -declaration is not checked. - -@noindent -For a deferred constant, the defining name in the corresponding full constant -declaration is not checked. - -Defining names of formal types are not checked. - -The rule may have the following parameters: - -@itemize @bullet -@item -For the @option{+R} option: -@table @code -@item Default -Sets the default listed above for all the names to be checked. - -@item Type_Suffix=@emph{string} -Specifies the suffix for a type name. - -@item Access_Suffix=@emph{string} -Specifies the suffix for an access type name. If -this parameter is set, it overrides for access -types the suffix set by the @code{Type_Suffix} parameter. -For access types, @emph{string} may have the following format: -@emph{suffix1(suffix2)}. That means that an access type name -should have the @emph{suffix1} suffix except for the case when -the designated type is also an access type, in this case the -type name should have the @emph{suffix1 & suffix2} suffix. - -@item Class_Access_Suffix=@emph{string} -Specifies the suffix for the name of an access type that points to some class-wide -type. If this parameter is set, it overrides for such access -types the suffix set by the @code{Type_Suffix} or @code{Access_Suffix} -parameter. - -@item Class_Subtype_Suffix=@emph{string} -Specifies the suffix for the name of a subtype that denotes a class-wide type. - -@item Constant_Suffix=@emph{string} -Specifies the suffix for a constant name. - -@item Renaming_Suffix=@emph{string} -Specifies the suffix for a package renaming name. -@end table - -@item -For the @option{-R} option: -@table @code -@item All_Suffixes -Remove all the suffixes specified for the -identifier suffix checks, whether by default or -as specified by other rule parameters. All the -checks for this rule are disabled as a result. - -@item Type_Suffix -Removes the suffix specified for types. This -disables checks for types but does not disable -any other checks for this rule (including the -check for access type names if @code{Access_Suffix} is -set). - -@item Access_Suffix -Removes the suffix specified for access types. -This disables checks for access type names but -does not disable any other checks for this rule. -If @code{Type_Suffix} is set, access type names are -checked as ordinary type names. - -@item Class_Access_Suffix -Removes the suffix specified for access types pointing to class-wide -type. This disables specific checks for names of access types pointing to -class-wide types but does not disable any other checks for this rule. -If @code{Type_Suffix} is set, access type names are -checked as ordinary type names. If @code{Access_Suffix} is set, these -access types are checked as any other access type name. - -@item Class_Subtype_Suffix=@emph{string} -Removes the suffix specified for subtype names. -This disables checks for subtype names but -does not disable any other checks for this rule. - -@item Constant_Suffix -Removes the suffix specified for constants. This -disables checks for constant names but does not -disable any other checks for this rule. - -@item Renaming_Suffix -Removes the suffix specified for package -renamings. This disables checks for package -renamings but does not disable any other checks -for this rule. -@end table -@end itemize - -@noindent -If more than one parameter is used, parameters must be separated by commas. - -If more than one option is specified for the @command{gnatcheck} invocation, -a new option overrides the previous one(s). - -The @option{+RMisnamed_Identifiers} option (with no parameter) enables -checks for all the -name suffixes specified by previous options used for this rule. - -The @option{-RMisnamed_Identifiers} option (with no parameter) disables -all the checks but keeps -all the suffixes specified by previous options used for this rule. - -The @emph{string} value must be a valid suffix for an Ada identifier (after -trimming all the leading and trailing space characters, if any). -Parameters are not case sensitive, except the @emph{string} part. - -If any error is detected in a rule parameter, the parameter is ignored. -In such a case the options that are set for the rule are not -specified. - - - -@node Multiple_Entries_In_Protected_Definitions -@subsection @code{Multiple_Entries_In_Protected_Definitions} -@cindex @code{Multiple_Entries_In_Protected_Definitions} rule (for @command{gnatcheck}) - -@noindent -Flag each protected definition (i.e., each protected object/type declaration) -that defines more than one entry. -Diagnostic messages are generated for all the entry declarations -except the first one. An entry family is counted as one entry. Entries from -the private part of the protected definition are also checked. - -This rule has no parameters. - -@node Name_Clashes -@subsection @code{Name_Clashes} -@cindex @code{Name_Clashes} rule (for @command{gnatcheck}) - -@noindent -Check that certain names are not used as defining identifiers. To activate -this rule, you need to supply a reference to the dictionary file(s) as a rule -parameter(s) (more then one dictionary file can be specified). If no -dictionary file is set, this rule will not cause anything to be flagged. -Only defining occurrences, not references, are checked. -The check is not case-sensitive. - -This rule is enabled by default, but without setting any corresponding -dictionary file(s); thus the default effect is to do no checks. - -A dictionary file is a plain text file. The maximum line length for this file -is 1024 characters. If the line is longer then this limit, extra characters -are ignored. - -Each line can be either an empty line, a comment line, or a line containing -a list of identifiers separated by space or HT characters. -A comment is an Ada-style comment (from @code{--} to end-of-line). -Identifiers must follow the Ada syntax for identifiers. -A line containing one or more identifiers may end with a comment. - -@node Non_Qualified_Aggregates -@subsection @code{Non_Qualified_Aggregates} -@cindex @code{Non_Qualified_Aggregates} rule (for @command{gnatcheck}) - -@noindent -Flag each non-qualified aggregate. -A non-qualified aggregate is an -aggregate that is not the expression of a qualified expression. A -string literal is not considered an aggregate, but an array -aggregate of a string type is considered as a normal aggregate. -Aggregates of anonymous array types are not flagged. - -This rule has no parameters. - - -@node Non_Short_Circuit_Operators -@subsection @code{Non_Short_Circuit_Operators} -@cindex @code{Non_Short_Circuit_Operators} rule (for @command{gnatcheck}) - -@noindent -Flag all calls to predefined @code{and} and @code{or} operators for -any boolean type. Calls to -user-defined @code{and} and @code{or} and to operators defined by renaming -declarations are not flagged. Calls to predefined @code{and} and @code{or} -operators for modular types or boolean array types are not flagged. - -This rule has no parameters. - - - -@node Non_SPARK_Attributes -@subsection @code{Non_SPARK_Attributes} -@cindex @code{Non_SPARK_Attributes} rule (for @command{gnatcheck}) - -@noindent -The SPARK language defines the following subset of Ada 95 attribute -designators as those that can be used in SPARK programs. The use of -any other attribute is flagged. - -@itemize @bullet -@item @code{'Adjacent} -@item @code{'Aft} -@item @code{'Base} -@item @code{'Ceiling} -@item @code{'Component_Size} -@item @code{'Compose} -@item @code{'Copy_Sign} -@item @code{'Delta} -@item @code{'Denorm} -@item @code{'Digits} -@item @code{'Exponent} -@item @code{'First} -@item @code{'Floor} -@item @code{'Fore} -@item @code{'Fraction} -@item @code{'Last} -@item @code{'Leading_Part} -@item @code{'Length} -@item @code{'Machine} -@item @code{'Machine_Emax} -@item @code{'Machine_Emin} -@item @code{'Machine_Mantissa} -@item @code{'Machine_Overflows} -@item @code{'Machine_Radix} -@item @code{'Machine_Rounds} -@item @code{'Max} -@item @code{'Min} -@item @code{'Model} -@item @code{'Model_Emin} -@item @code{'Model_Epsilon} -@item @code{'Model_Mantissa} -@item @code{'Model_Small} -@item @code{'Modulus} -@item @code{'Pos} -@item @code{'Pred} -@item @code{'Range} -@item @code{'Remainder} -@item @code{'Rounding} -@item @code{'Safe_First} -@item @code{'Safe_Last} -@item @code{'Scaling} -@item @code{'Signed_Zeros} -@item @code{'Size} -@item @code{'Small} -@item @code{'Succ} -@item @code{'Truncation} -@item @code{'Unbiased_Rounding} -@item @code{'Val} -@item @code{'Valid} -@end itemize - -@noindent -This rule has no parameters. - - -@node Non_Tagged_Derived_Types -@subsection @code{Non_Tagged_Derived_Types} -@cindex @code{Non_Tagged_Derived_Types} rule (for @command{gnatcheck}) - -@noindent -Flag all derived type declarations that do not have a record extension part. - -This rule has no parameters. - - - -@node Non_Visible_Exceptions -@subsection @code{Non_Visible_Exceptions} -@cindex @code{Non_Visible_Exceptions} rule (for @command{gnatcheck}) - -@noindent -Flag constructs leading to the possibility of propagating an exception -out of the scope in which the exception is declared. -Two cases are detected: - -@itemize @bullet -@item -An exception declaration in a subprogram body, task body or block -statement is flagged if the body or statement does not contain a handler for -that exception or a handler with an @code{others} choice. - -@item -A @code{raise} statement in an exception handler of a subprogram body, -task body or block statement is flagged if it (re)raises a locally -declared exception. This may occur under the following circumstances: -@itemize @minus -@item -it explicitly raises a locally declared exception, or -@item -it does not specify an exception name (i.e., it is simply @code{raise;}) -and the enclosing handler contains a locally declared exception in its -exception choices. -@end itemize -@end itemize - -@noindent -Renamings of local exceptions are not flagged. - -This rule has no parameters. - - -@node Numeric_Literals -@subsection @code{Numeric_Literals} -@cindex @code{Numeric_Literals} rule (for @command{gnatcheck}) - -@noindent -Flag each use of a numeric literal in an index expression, and in any -circumstance except for the following: - -@itemize @bullet -@item -a literal occurring in the initialization expression for a constant -declaration or a named number declaration, or - -@item -an integer literal that is less than or equal to a value -specified by the @option{N} rule parameter. -@end itemize - -@noindent -This rule may have the following parameters for the @option{+R} option: - -@table @asis -@item @emph{N} -@emph{N} is an integer literal used as the maximal value that is not flagged -(i.e., integer literals not exceeding this value are allowed) - -@item @code{ALL} -All integer literals are flagged -@end table - -@noindent -If no parameters are set, the maximum unflagged value is 1. - -The last specified check limit (or the fact that there is no limit at -all) is used when multiple @option{+R} options appear. - -The @option{-R} option for this rule has no parameters. -It disables the rule but retains the last specified maximum unflagged value. -If the @option{+R} option subsequently appears, this value is used as the -threshold for the check. - - -@node OTHERS_In_Aggregates -@subsection @code{OTHERS_In_Aggregates} -@cindex @code{OTHERS_In_Aggregates} rule (for @command{gnatcheck}) - -@noindent -Flag each use of an @code{others} choice in extension aggregates. -In record and array aggregates, an @code{others} choice is flagged unless -it is used to refer to all components, or to all but one component. - -If, in case of a named array aggregate, there are two associations, one -with an @code{others} choice and another with a discrete range, the -@code{others} choice is flagged even if the discrete range specifies -exactly one component; for example, @code{(1..1 => 0, others => 1)}. - -This rule has no parameters. - -@node OTHERS_In_CASE_Statements -@subsection @code{OTHERS_In_CASE_Statements} -@cindex @code{OTHERS_In_CASE_Statements} rule (for @command{gnatcheck}) - -@noindent -Flag any use of an @code{others} choice in a @code{case} statement. - -This rule has no parameters. - -@node OTHERS_In_Exception_Handlers -@subsection @code{OTHERS_In_Exception_Handlers} -@cindex @code{OTHERS_In_Exception_Handlers} rule (for @command{gnatcheck}) - -@noindent -Flag any use of an @code{others} choice in an exception handler. - -This rule has no parameters. - - -@node Outer_Loop_Exits -@subsection @code{Outer_Loop_Exits} -@cindex @code{Outer_Loop_Exits} rule (for @command{gnatcheck}) - -@noindent -Flag each @code{exit} statement containing a loop name that is not the name -of the immediately enclosing @code{loop} statement. - -This rule has no parameters. - - -@node Overloaded_Operators -@subsection @code{Overloaded_Operators} -@cindex @code{Overloaded_Operators} rule (for @command{gnatcheck}) - -@noindent -Flag each function declaration that overloads an operator symbol. -A function body is checked only if the body does not have a -separate spec. Formal functions are also checked. For a -renaming declaration, only renaming-as-declaration is checked - -This rule has no parameters. - - -@node Overly_Nested_Control_Structures -@subsection @code{Overly_Nested_Control_Structures} -@cindex @code{Overly_Nested_Control_Structures} rule (for @command{gnatcheck}) - -@noindent -Flag each control structure whose nesting level exceeds the value provided -in the rule parameter. - -The control structures checked are the following: - -@itemize @bullet -@item @code{if} statement -@item @code{case} statement -@item @code{loop} statement -@item Selective accept statement -@item Timed entry call statement -@item Conditional entry call -@item Asynchronous select statement -@end itemize - -@noindent -The rule has the following parameter for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximal control structure nesting -level that is not flagged -@end table - -@noindent -If the parameter for the @option{+R} option is not specified or -if it is not a positive integer, @option{+R} option is ignored. - -If more then one option is specified for the gnatcheck call, the later option and -new parameter override the previous one(s). - - -@node Parameters_Out_Of_Order -@subsection @code{Parameters_Out_Of_Order} -@cindex @code{Parameters_Out_Of_Order} rule (for @command{gnatcheck}) - -@noindent -Flag each subprogram and entry declaration whose formal parameters are not -ordered according to the following scheme: - -@itemize @bullet - -@item @code{in} and @code{access} parameters first, -then @code{in out} parameters, -and then @code{out} parameters; - -@item for @code{in} mode, parameters with default initialization expressions -occur last -@end itemize - -@noindent -Only the first violation of the described order is flagged. - -The following constructs are checked: - -@itemize @bullet -@item subprogram declarations (including null procedures); -@item generic subprogram declarations; -@item formal subprogram declarations; -@item entry declarations; -@item subprogram bodies and subprogram body stubs that do not -have separate specifications -@end itemize - -@noindent -Subprogram renamings are not checked. - -This rule has no parameters. - - -@node Positional_Actuals_For_Defaulted_Generic_Parameters -@subsection @code{Positional_Actuals_For_Defaulted_Generic_Parameters} -@cindex @code{Positional_Actuals_For_Defaulted_Generic_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flag each generic actual parameter corresponding to a generic formal -parameter with a default initialization, if positional notation is used. - -This rule has no parameters. - -@node Positional_Actuals_For_Defaulted_Parameters -@subsection @code{Positional_Actuals_For_Defaulted_Parameters} -@cindex @code{Positional_Actuals_For_Defaulted_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flag each actual parameter to a subprogram or entry call where the -corresponding formal parameter has a default expression, if positional -notation is used. - -This rule has no parameters. - -@node Positional_Components -@subsection @code{Positional_Components} -@cindex @code{Positional_Components} rule (for @command{gnatcheck}) - -@noindent -Flag each array, record and extension aggregate that includes positional -notation. - -This rule has no parameters. - - -@node Positional_Generic_Parameters -@subsection @code{Positional_Generic_Parameters} -@cindex @code{Positional_Generic_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flag each positional actual generic parameter except for the case when -the generic unit being iinstantiated has exactly one generic formal -parameter. - -This rule has no parameters. - - -@node Positional_Parameters -@subsection @code{Positional_Parameters} -@cindex @code{Positional_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flag each positional parameter notation in a subprogram or entry call, -except for the following: - -@itemize @bullet -@item -Parameters of calls to of prefix or infix operators are not flagged -@item -If the called subprogram or entry has only one formal parameter, -the parameter of the call is not flagged; -@item -If a subprogram call uses the @emph{Object.Operation} notation, then -@itemize @minus -@item -the first parameter (that is, @emph{Object}) is not flagged; -@item -if the called subprogram has only two parameters, the second parameter -of the call is not flagged; -@end itemize -@end itemize - -@noindent -This rule has no parameters. - - - - -@node Predefined_Numeric_Types -@subsection @code{Predefined_Numeric_Types} -@cindex @code{Predefined_Numeric_Types} rule (for @command{gnatcheck}) - -@noindent -Flag each explicit use of the name of any numeric type or subtype defined -in package @code{Standard}. - -The rationale for this rule is to detect when the -program may depend on platform-specific characteristics of the implementation -of the predefined numeric types. Note that this rule is over-pessimistic; -for example, a program that uses @code{String} indexing -likely needs a variable of type @code{Integer}. -Another example is the flagging of predefined numeric types with explicit -constraints: - -@smallexample @c ada - subtype My_Integer is Integer range Left .. Right; - Vy_Var : My_Integer; -@end smallexample - -@noindent -This rule detects only numeric types and subtypes defined in -@code{Standard}. The use of numeric types and subtypes defined in other -predefined packages (such as @code{System.Any_Priority} or -@code{Ada.Text_IO.Count}) is not flagged - -This rule has no parameters. - - - -@node Raising_External_Exceptions -@subsection @code{Raising_External_Exceptions} -@cindex @code{Raising_External_Exceptions} rule (for @command{gnatcheck}) - -@noindent -Flag any @code{raise} statement, in a program unit declared in a library -package or in a generic library package, for an exception that is -neither a predefined exception nor an exception that is also declared (or -renamed) in the visible part of the package. - -This rule has no parameters. - - - -@node Raising_Predefined_Exceptions -@subsection @code{Raising_Predefined_Exceptions} -@cindex @code{Raising_Predefined_Exceptions} rule (for @command{gnatcheck}) - -@noindent -Flag each @code{raise} statement that raises a predefined exception -(i.e., one of the exceptions @code{Constraint_Error}, @code{Numeric_Error}, -@code{Program_Error}, @code{Storage_Error}, or @code{Tasking_Error}). - -This rule has no parameters. - -@node Separate_Numeric_Error_Handlers -@subsection @code{Separate_Numeric_Error_Handlers} -@cindex @code{Separate_Numeric_Error_Handlers} rule (for @command{gnatcheck}) - -@noindent -Flags each exception handler that contains a choice for -the predefined @code{Constraint_Error} exception, but does not contain -the choice for the predefined @code{Numeric_Error} exception, or -that contains the choice for @code{Numeric_Error}, but does not contain the -choice for @code{Constraint_Error}. - -This rule has no parameters. - -@ignore -@node Recursion -@subsection @code{Recursion} (under construction, GLOBAL) -@cindex @code{Recursion} rule (for @command{gnatcheck}) - -@noindent -Flag recursive subprograms (cycles in the call graph). Declarations, and not -calls, of recursive subprograms are detected. - -This rule has no parameters. -@end ignore - -@ignore -@node Side_Effect_Functions -@subsection @code{Side_Effect_Functions} (under construction, GLOBAL) -@cindex @code{Side_Effect_Functions} rule (for @command{gnatcheck}) - -@noindent -Flag functions with side effects. - -We define a side effect as changing any data object that is not local for the -body of this function. - -At the moment, we do NOT consider a side effect any input-output operations -(changing a state or a content of any file). - -We do not consider protected functions for this rule (???) - -There are the following sources of side effect: - -@enumerate -@item Explicit (or direct) side-effect: - -@itemize @bullet -@item -direct assignment to a non-local variable; - -@item -direct call to an entity that is known to change some data object that is - not local for the body of this function (Note, that if F1 calls F2 and F2 - does have a side effect, this does not automatically mean that F1 also - have a side effect, because it may be the case that F2 is declared in - F1's body and it changes some data object that is global for F2, but - local for F1); -@end itemize - -@item Indirect side-effect: -@itemize @bullet -@item -Subprogram calls implicitly issued by: -@itemize @bullet -@item -computing initialization expressions from type declarations as a part - of object elaboration or allocator evaluation; -@item -computing implicit parameters of subprogram or entry calls or generic - instantiations; -@end itemize - -@item -activation of a task that change some non-local data object (directly or - indirectly); - -@item -elaboration code of a package that is a result of a package instantiation; - -@item -controlled objects; -@end itemize - -@item Situations when we can suspect a side-effect, but the full static check -is either impossible or too hard: -@itemize @bullet -@item -assignment to access variables or to the objects pointed by access - variables; - -@item -call to a subprogram pointed by access-to-subprogram value - -@item -dispatching calls; -@end itemize -@end enumerate - -@noindent -This rule has no parameters. -@end ignore - -@node Slices -@subsection @code{Slices} -@cindex @code{Slices} rule (for @command{gnatcheck}) - -@noindent -Flag all uses of array slicing - -This rule has no parameters. - - -@node Too_Many_Parents -@subsection @code{Too_Many_Parents} -@cindex @code{Too_Many_Parents} rule (for @command{gnatcheck}) - -@noindent -Flags any type declaration, single task declaration or single protected -declaration that has more then @option{N} parents, @option{N} is a parameter -of the rule. -A parent here is either a (sub)type denoted by the subtype mark from the -parent_subtype_indication (in case of a derived type declaration), or -any of the progenitors from the interface list, if any. - -This rule has the following (mandatory) parameters for the @option{+R} option: - -@table @emph -@item N -Positive integer specifying the maximal allowed number of parents. -@end table - - -@node Unassigned_OUT_Parameters -@subsection @code{Unassigned_OUT_Parameters} -@cindex @code{Unassigned_OUT_Parameters} rule (for @command{gnatcheck}) - -@noindent -Flags procedures' @code{out} parameters that are not assigned, and -identifies the contexts in which the assignments are missing. - -An @code{out} parameter is flagged in the statements in the procedure -body's handled sequence of statements (before the procedure body's -@code{exception} part, if any) if this sequence of statements contains -no assignments to the parameter. - -An @code{out} parameter is flagged in an exception handler in the exception -part of the procedure body's handled sequence of statements if the handler -contains no assignment to the parameter. - -Bodies of generic procedures are also considered. - -The following are treated as assignments to an @code{out} parameter: - -@itemize @bullet -@item -an assignment statement, with the parameter or some component as the target; - -@item -passing the parameter (or one of its components) as an @code{out} or -@code{in out} parameter. -@end itemize - -@noindent -This rule does not have any parameters. - - - -@node Uncommented_BEGIN_In_Package_Bodies -@subsection @code{Uncommented_BEGIN_In_Package_Bodies} -@cindex @code{Uncommented_BEGIN_In_Package_Bodies} rule (for @command{gnatcheck}) - -@noindent -Flags each package body with declarations and a statement part that does not -include a trailing comment on the line containing the @code{begin} keyword; -this trailing comment needs to specify the package name and nothing else. -The @code{begin} is not flagged if the package body does not -contain any declarations. - -If the @code{begin} keyword is placed on the -same line as the last declaration or the first statement, it is flagged -independently of whether the line contains a trailing comment. The -diagnostic message is attached to the line containing the first statement. - -This rule has no parameters. - -@node Unconditional_Exits -@subsection @code{Unconditional_Exits} -@cindex @code{Unconditional_Exits} rule (for @command{gnatcheck}) - -@noindent -Flag unconditional @code{exit} statements. - -This rule has no parameters. - -@node Unconstrained_Array_Returns -@subsection @code{Unconstrained_Array_Returns} -@cindex @code{Unconstrained_Array_Returns} rule (for @command{gnatcheck}) - -@noindent -Flag each function returning an unconstrained array. Function declarations, -function bodies (and body stubs) having no separate specifications, -and generic function instantiations are checked. -Function calls and function renamings are -not checked. - -Generic function declarations, and function declarations in generic -packages are not checked, instead this rule checks the results of -generic instantiations (that is, expanded specification and expanded -body corresponding to an instantiation). - -This rule has no parameters. - -@node Universal_Ranges -@subsection @code{Universal_Ranges} -@cindex @code{Universal_Ranges} rule (for @command{gnatcheck}) - -@noindent -Flag discrete ranges that are a part of an index constraint, constrained -array definition, or @code{for}-loop parameter specification, and whose bounds -are both of type @i{universal_integer}. Ranges that have at least one -bound of a specific type (such as @code{1 .. N}, where @code{N} is a variable -or an expression of non-universal type) are not flagged. - -This rule has no parameters. - - -@node Unnamed_Blocks_And_Loops -@subsection @code{Unnamed_Blocks_And_Loops} -@cindex @code{Unnamed_Blocks_And_Loops} rule (for @command{gnatcheck}) - -@noindent -Flag each unnamed block statement and loop statement. - -The rule has no parameters. - - - -@ignore -@node Unused_Subprograms -@subsection @code{Unused_Subprograms} (under construction, GLOBAL) -@cindex @code{Unused_Subprograms} rule (for @command{gnatcheck}) - -@noindent -Flag all unused subprograms. - -This rule has no parameters. -@end ignore - - - - -@node USE_PACKAGE_Clauses -@subsection @code{USE_PACKAGE_Clauses} -@cindex @code{USE_PACKAGE_Clauses} rule (for @command{gnatcheck}) - -@noindent -Flag all @code{use} clauses for packages; @code{use type} clauses are -not flagged. - -This rule has no parameters. - - -@node Visible_Components -@subsection @code{Visible_Components} -@cindex @code{Visible_Components} rule (for @command{gnatcheck}) - -@noindent -Flags all the type declarations located in the visible part of a library -package or a library generic package that can declare a visible component. A -type is considered as declaring a visible component if it contains a record -definition by its own or as a part of a record extension. Type declaration is -flagged even if it contains a record definition that defines no components. - -Declarations located in private parts of local (generic) packages are not -flagged. Declarations in private packages are not flagged. - -This rule has no parameters. - - -@node Volatile_Objects_Without_Address_Clauses -@subsection @code{Volatile_Objects_Without_Address_Clauses} -@cindex @code{Volatile_Objects_Without_Address_Clauses} rule (for @command{gnatcheck}) - -@noindent -Flag each volatile object that does not have an address clause. - -The following check is made: if the pragma @code{Volatile} is applied to a -data object or to its type, then an address clause must -be supplied for this object. - -This rule does not check the components of data objects, -array components that are volatile as a result of the pragma -@code{Volatile_Components}, or objects that are volatile because -they are atomic as a result of pragmas @code{Atomic} or -@code{Atomic_Components}. - -Only variable declarations, and not constant declarations, are checked. +The predefined rules implemented in @command{gnatcheck} +are described in a companion document, +@cite{GNATcheck Reference Manual -- Predefined Rules}. +The rule identifier is +used as a parameter of @command{gnatcheck}'s @option{+R} or @option{-R} +switches. -This rule has no parameters. @node Example of gnatcheck Usage @section Example of @command{gnatcheck} Usage @@ -24221,6 +18859,7 @@ the incorrect user program. * Ada Exceptions:: * Ada Tasks:: * Debugging Generic Units:: +* Remote Debugging using gdbserver:: * GNAT Abnormal Termination or Failure to Terminate:: * Naming Conventions for GNAT Source Files:: * Getting Internal Debugging Information:: @@ -24366,11 +19005,10 @@ and execution encounters the breakpoint, then the program stops and @code{GDB} signals that the breakpoint was encountered by printing the line of code before which the program is halted. -@item breakpoint exception @var{name} -A special form of the breakpoint command which breakpoints whenever -exception @var{name} is raised. -If @var{name} is omitted, -then a breakpoint will occur when any exception is raised. +@item catch exception @var{name} +This command causes the program execution to stop whenever exception +@var{name} is raised. If @var{name} is omitted, then the execution is +suspended when any exception is raised. @item print @var{expression} This will print the value of the given expression. Most simple @@ -24532,25 +19170,25 @@ The value returned is always that from the first return statement that was stepped through. @node Ada Exceptions -@section Breaking on Ada Exceptions +@section Stopping when Ada Exceptions are Raised @cindex Exceptions @noindent -You can set breakpoints that trip when your program raises -selected exceptions. +You can set catchpoints that stop the program execution when your program +raises selected exceptions. @table @code -@item break exception -Set a breakpoint that trips whenever (any task in the) program raises -any exception. +@item catch exception +Set a catchpoint that stops execution whenever (any task in the) program +raises any exception. -@item break exception @var{name} -Set a breakpoint that trips whenever (any task in the) program raises -the exception @var{name}. +@item catch exception @var{name} +Set a catchpoint that stops execution whenever (any task in the) program +raises the exception @var{name}. -@item break exception unhandled -Set a breakpoint that trips whenever (any task in the) program raises an -exception for which there is no handler. +@item catch exception unhandled +Set a catchpoint that stops executino whenever (any task in the) program +raises an exception for which there is no handler. @item info exceptions @itemx info exceptions @var{regexp} @@ -24679,6 +19317,56 @@ When the breakpoint occurs, you can step through the code of the instance in the normal manner and examine the values of local variables, as for other units. +@node Remote Debugging using gdbserver +@section Remote Debugging using gdbserver +@cindex Remote Debugging using gdbserver + +@noindent +On platforms where gdbserver is supported, it is possible to use this tool +to debug your application remotely. This can be useful in situations +where the program needs to be run on a target host that is different +from the host used for development, particularly when the target has +a limited amount of resources (either CPU and/or memory). + +To do so, start your program using gdbserver on the target machine. +gdbserver then automatically suspends the execution of your program +at its entry point, waiting for a debugger to connect to it. The +following commands starts an application and tells gdbserver to +wait for a connection with the debugger on localhost port 4444. + +@smallexample +$ gdbserver localhost:4444 program +Process program created; pid = 5685 +Listening on port 4444 +@end smallexample + +Once gdbserver has started listening, we can tell the debugger to establish +a connection with this gdbserver, and then start the same debugging session +as if the program was being debugged on the same host, directly under +the control of GDB. + +@smallexample +$ gdb program +(gdb) target remote targethost:4444 +Remote debugging using targethost:4444 +0x00007f29936d0af0 in ?? () from /lib64/ld-linux-x86-64.so. +(gdb) b foo.adb:3 +Breakpoint 1 at 0x401f0c: file foo.adb, line 3. +(gdb) continue +Continuing. + +Breakpoint 1, foo () at foo.adb:4 +4 end foo; +@end smallexample + +It is also possible to use gdbserver to attach to an already running +program, in which case the execution of that program is simply suspended +until the connection between the debugger and gdbserver is established. + +For more information on how to use gdbserver, @ref{Top, Server, Using +the gdbserver Program, gdb, Debugging with GDB}. GNAT Pro provides support +for gdbserver on x86-linux, x86-windows and x86_64-linux. + @node GNAT Abnormal Termination or Failure to Terminate @section GNAT Abnormal Termination or Failure to Terminate @cindex GNAT Abnormal Termination or Failure to Terminate @@ -26030,7 +20718,9 @@ Unlike HP Ada, the GNAT ``@code{EXPORT_}@i{subprogram}'' pragmas require a separate subprogram specification which must appear before the subprogram body. -GNAT also supplies a number of implementation-defined pragmas as follows: +GNAT also supplies a number of implementation-defined pragmas including the +following: + @itemize @bullet @item @code{ABORT_DEFER} @@ -26040,6 +20730,12 @@ GNAT also supplies a number of implementation-defined pragmas as follows: @item @code{ADA_05} +@item @code{Ada_2005} + +@item @code{Ada_12} + +@item @code{Ada_2012} + @item @code{ANNOTATE} @item @code{ASSERT} @@ -26086,7 +20782,7 @@ GNAT also supplies a number of implementation-defined pragmas as follows: @end itemize @noindent -For full details on these GNAT implementation-defined pragmas, +For full details on these and other GNAT implementation-defined pragmas, see @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}. @@ -27345,7 +22041,8 @@ Windows executables that run in Ring 3 to utilize memory protection @item Real-time subsystem (RTSS) executables that run in Ring 0, where performance can be optimized with RTSS applications taking precedent -over all Windows applications (@emph{rts-rtx-rtss}). +over all Windows applications (@emph{rts-rtx-rtss}). This mode requires +the Microsoft linker to handle RTSS libraries. @end itemize diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 11dd9a8b62c..cb234d262e6 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -45,6 +45,7 @@ with Rident; use Rident; with Snames; with Switch; use Switch; with Switch.B; use Switch.B; +with Table; with Targparm; use Targparm; with Types; use Types; @@ -81,6 +82,16 @@ procedure Gnatbind is Mapping_File : String_Ptr := null; + package Closure_Sources is new Table.Table + (Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatbind.Closure_Sources"); + -- Table to record the sources in the closure, to avoid duplications. Used + -- only with switch -R. + function Gnatbind_Supports_Auto_Init return Boolean; -- Indicates if automatic initialization of elaboration procedure -- through the constructor mechanism is possible on the platform. @@ -727,10 +738,10 @@ begin Free (Text); end if; - -- Acquire all information in ALI files that have been read in + -- Load ALIs for all dependent units for Index in ALIs.First .. ALIs.Last loop - Read_ALI (Index); + Read_Withed_ALIs (Index); end loop; -- Quit if some file needs compiling @@ -739,6 +750,28 @@ begin raise Unrecoverable_Error; end if; + -- Output list of ALI files in closure + + if Output_ALI_List then + if ALI_List_Filename /= null then + Set_List_File (ALI_List_Filename.all); + end if; + + for Index in ALIs.First .. ALIs.Last loop + declare + Full_Afile : constant File_Name_Type := + Find_File (ALIs.Table (Index).Afile, Library); + begin + Write_Name (Full_Afile); + Write_Eol; + end; + end loop; + + if ALI_List_Filename /= null then + Close_List_File; + end if; + end if; + -- Build source file table from the ALI files we have read in Set_Source_Table; @@ -815,55 +848,90 @@ begin -- sources) if -R was used. if List_Closure then - if not Zero_Formatting then - Write_Eol; - Write_Str ("REFERENCED SOURCES"); - Write_Eol; - end if; + List_Closure_Display : declare + Source : File_Name_Type; - for J in reverse Elab_Order.First .. Elab_Order.Last loop + function Put_In_Sources (S : File_Name_Type) return Boolean; + -- Check if S is already in table Sources and put in Sources + -- if it is not. Return False if the source is already in + -- Sources, and True if it is added. - -- Do not include the sources of the runtime + -------------------- + -- Put_In_Sources -- + -------------------- - if not Is_Internal_File_Name - (Units.Table (Elab_Order.Table (J)).Sfile) - then - if not Zero_Formatting then - Write_Str (" "); - end if; + function Put_In_Sources (S : File_Name_Type) + return Boolean + is + begin + for J in 1 .. Closure_Sources.Last loop + if Closure_Sources.Table (J) = S then + return False; + end if; + end loop; + + Closure_Sources.Append (S); + return True; + end Put_In_Sources; + + -- Start of processing for List_Closure_Display + + begin + Closure_Sources.Init; - Write_Str - (Get_Name_String - (Units.Table (Elab_Order.Table (J)).Sfile)); + if not Zero_Formatting then + Write_Eol; + Write_Str ("REFERENCED SOURCES"); Write_Eol; end if; - end loop; - -- Subunits do not appear in the elaboration table because they - -- are subsumed by their parent units, but we need to list them - -- for other tools. For now they are listed after other files, - -- rather than right after their parent, since there is no easy - -- link between the elaboration table and the ALIs table ??? - -- Note also that subunits may appear repeatedly in the list, - -- if the parent unit appears in the context of several units - -- in the closure. - - for J in Sdep.First .. Sdep.Last loop - if Sdep.Table (J).Subunit_Name /= No_Name - and then not Is_Internal_File_Name (Sdep.Table (J).Sfile) - then - if not Zero_Formatting then - Write_Str (" "); + for J in reverse Elab_Order.First .. Elab_Order.Last loop + Source := Units.Table (Elab_Order.Table (J)).Sfile; + + -- Do not include the sources of the runtime and do not + -- include the same source several times. + + if Put_In_Sources (Source) + and then not Is_Internal_File_Name (Source) + then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Str (Get_Name_String (Source)); + Write_Eol; end if; + end loop; + + -- Subunits do not appear in the elaboration table because + -- they are subsumed by their parent units, but we need to + -- list them for other tools. For now they are listed after + -- other files, rather than right after their parent, since + -- there is no easy link between the elaboration table and + -- the ALIs table ??? As subunits may appear repeatedly in + -- the list, if the parent unit appears in the context of + -- several units in the closure, duplicates are suppressed. + + for J in Sdep.First .. Sdep.Last loop + Source := Sdep.Table (J).Sfile; + + if Sdep.Table (J).Subunit_Name /= No_Name + and then Put_In_Sources (Source) + and then not Is_Internal_File_Name (Source) + then + if not Zero_Formatting then + Write_Str (" "); + end if; + + Write_Str (Get_Name_String (Source)); + Write_Eol; + end if; + end loop; - Write_Str (Get_Name_String (Sdep.Table (J).Sfile)); + if not Zero_Formatting then Write_Eol; end if; - end loop; - - if not Zero_Formatting then - Write_Eol; - end if; + end List_Closure_Display; end if; end if; end if; diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 041c82aee7f..0f3810144e4 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, 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- -- @@ -122,6 +122,7 @@ procedure GNATCmd is Naming_String : constant SA := new String'("naming"); Binder_String : constant SA := new String'("binder"); + Builder_String : constant SA := new String'("builder"); Compiler_String : constant SA := new String'("compiler"); Check_String : constant SA := new String'("check"); Synchronize_String : constant SA := new String'("synchronize"); @@ -139,7 +140,8 @@ procedure GNATCmd is new String_List'((Naming_String, Binder_String)); Packages_To_Check_By_Check : constant String_List_Access := - new String_List'((Naming_String, Check_String, Compiler_String)); + new String_List' + ((Naming_String, Builder_String, Check_String, Compiler_String)); Packages_To_Check_By_Sync : constant String_List_Access := new String_List'((Naming_String, Synchronize_String, Compiler_String)); @@ -333,13 +335,11 @@ procedure GNATCmd is if Index = 1 or else (The_Command = Check - and then - Last_Switches.Table (Index - 1).all /= "-o") + and then Last_Switches.Table (Index - 1).all /= "-o") or else (The_Command = Pretty - and then - Last_Switches.Table (Index - 1).all /= "-o" and then - Last_Switches.Table (Index - 1).all /= "-of") + and then Last_Switches.Table (Index - 1).all /= "-o" + and then Last_Switches.Table (Index - 1).all /= "-of") or else (The_Command = Metric and then @@ -363,7 +363,7 @@ procedure GNATCmd is if Add_Sources then - -- For gnatcheck, gnatpp and gnatmetric , create a temporary file + -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file -- and put the list of sources in it. if The_Command = Check or else @@ -455,8 +455,8 @@ procedure GNATCmd is then -- There is a body, check if it is for this project - if All_Projects or else - Unit.File_Names (Impl).Project = Project + if All_Projects + or else Unit.File_Names (Impl).Project = Project then Subunit := False; @@ -1083,8 +1083,7 @@ procedure GNATCmd is -- Append ".ali" if file name does not end with it if Switch'Length <= 4 - or else Switch (Switch'Last - 3 .. Switch'Last) - /= ".ali" + or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali" then Last := ALI_File'Last; end if; @@ -1097,8 +1096,8 @@ procedure GNATCmd is else for K in Switch'Range loop - if Switch (K) = '/' or else - Switch (K) = Directory_Separator + if Switch (K) = '/' + or else Switch (K) = Directory_Separator then Test_Existence := True; exit; @@ -1272,7 +1271,10 @@ procedure GNATCmd is New_Line; for C in Command_List'Range loop - if not Command_List (C).VMS_Only then + + -- No usage for VMS only command or for Sync + + if not Command_List (C).VMS_Only and then C /= Sync then if Targparm.AAMP_On_Target then Put ("gnaampcmd "); else @@ -1306,7 +1308,7 @@ procedure GNATCmd is end loop; New_Line; - Put_Line ("Commands find, list, metric, pretty, stack, stub and xref " & + Put_Line ("All commands except chop, krunch and preprocess " & "accept project file switches -vPx, -Pprj and -Xnam=val"); New_Line; end Non_VMS_Usage; @@ -1638,11 +1640,12 @@ begin -- --subdirs=... Specify Subdirs - if Argv'Length > Makeutl.Subdirs_Option'Length and then - Argv - (Argv'First .. - Argv'First + Makeutl.Subdirs_Option'Length - 1) = - Makeutl.Subdirs_Option + if Argv'Length > Makeutl.Subdirs_Option'Length + and then + Argv + (Argv'First .. + Argv'First + Makeutl.Subdirs_Option'Length - 1) = + Makeutl.Subdirs_Option then Subdirs := new String' @@ -1751,8 +1754,9 @@ begin ('=', Argv (Argv'First + 2 .. Argv'Last)); begin - if Equal_Pos >= Argv'First + 3 and then - Equal_Pos /= Argv'Last then + if Equal_Pos >= Argv'First + 3 + and then Equal_Pos /= Argv'Last + then Add (Project_Node_Tree, External_Name => Argv (Argv'First + 2 .. Equal_Pos - 1), @@ -1954,7 +1958,7 @@ begin end if; end; - if The_Command = Bind + if The_Command = Bind or else The_Command = Link or else The_Command = Elim then @@ -1969,7 +1973,7 @@ begin -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create -- a configuration pragmas file, if necessary. - if The_Command = Pretty + if The_Command = Pretty or else The_Command = Metric or else The_Command = Stub or else The_Command = Elim @@ -2107,7 +2111,7 @@ begin while K <= First_Switches.Last and then (The_Command /= Check - or else First_Switches.Table (K).all /= "-rules") + or else First_Switches.Table (K).all /= "-rules") loop Add_To_Carg_Switches (First_Switches.Table (K)); K := K + 1; @@ -2147,8 +2151,7 @@ begin while K <= Last_Switches.Last and then (The_Command /= Check - or else - Last_Switches.Table (K).all /= "-rules") + or else Last_Switches.Table (K).all /= "-rules") loop Add_To_Carg_Switches (Last_Switches.Table (K)); K := K + 1; @@ -2195,6 +2198,90 @@ begin Add_To_Carg_Switches (new String'("-gnatem=" & Get_Name_String (M_File))); end if; + + -- For gnatcheck, also indicate a global configuration pragmas + -- file and, if -U is not used, a local one. + + if The_Command = Check then + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Builder, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Variable : Variable_Value := + Prj.Util.Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Global_Configuration_Pragmas, + In_Package => Pkg, + In_Tree => Project_Tree); + + begin + if (Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0) + and then Pkg /= No_Package + then + Variable := + Prj.Util.Value_Of + (Name => Name_Ada, + Attribute_Or_Array_Name => + Name_Global_Config_File, + In_Package => Pkg, + In_Tree => Project_Tree); + end if; + + if Variable /= Nil_Variable_Value + and then Length_Of_Name (Variable.Value) /= 0 + then + Add_To_Carg_Switches + (new String' + ("-gnatec=" & Get_Name_String (Variable.Value))); + end if; + end; + + if not All_Projects then + declare + Pkg : constant Prj.Package_Id := + Prj.Util.Value_Of + (Name => Name_Compiler, + In_Packages => Project.Decl.Packages, + In_Tree => Project_Tree); + + Variable : Variable_Value := + Prj.Util.Value_Of + (Name => No_Name, + Attribute_Or_Array_Name => + Name_Local_Configuration_Pragmas, + In_Package => Pkg, + In_Tree => Project_Tree); + + begin + if (Variable = Nil_Variable_Value + or else Length_Of_Name (Variable.Value) = 0) + and then Pkg /= No_Package + then + Variable := + Prj.Util.Value_Of + (Name => Name_Ada, + Attribute_Or_Array_Name => + Name_Local_Config_File, + In_Package => Pkg, + In_Tree => Project_Tree); + end if; + + if Variable /= Nil_Variable_Value + and then Length_Of_Name (Variable.Value) /= 0 + then + Add_To_Carg_Switches + (new String' + ("-gnatec=" & + Get_Name_String (Variable.Value))); + end if; + end; + end if; + end if; end; end if; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index e6eec4f2006..675d9a364e4 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -1447,8 +1447,6 @@ procedure Gnatlink is Write_Eol; Write_Line (" mainprog.ali the ALI file of the main program"); Write_Eol; - Write_Line (" -A Binder generated source file is in Ada (default)"); - Write_Line (" -C Binder generated source file is in C"); Write_Line (" -f force object file list to be generated"); Write_Line (" -g Compile binder source file with debug information"); Write_Line (" -n Do not compile the binder source file"); diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 4c935bebbc7..00ebebe413e 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -306,7 +306,20 @@ procedure Gnatname is -- Add and initialize another component to Arguments table - Arguments.Increment_Last; + declare + New_Arguments : Argument_Data; + pragma Warnings (Off, New_Arguments); + -- Declaring this defaulted initialized object ensures + -- that the new allocated component of table Arguments + -- is correctly initialized. + + -- This is VERY ugly, Table should never be used with + -- data requiring default initialization. We should + -- find a way to avoid violating this rule ??? + + begin + Arguments.Append (New_Arguments); + end; Patterns.Init (Arguments.Table (Arguments.Last).Directories); diff --git a/gcc/ada/gnatsym.adb b/gcc/ada/gnatsym.adb index dec5257f45c..5a88994a4c4 100644 --- a/gcc/ada/gnatsym.adb +++ b/gcc/ada/gnatsym.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,19 +41,19 @@ -- - (optional) the name of the reference symbol file -- - the names of one or more object files where the symbols are found -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Text_IO; use Ada.Text_IO; - -with GNAT.Command_Line; use GNAT.Command_Line; -with GNAT.OS_Lib; use GNAT.OS_Lib; - with Gnatvsn; use Gnatvsn; with Osint; use Osint; with Output; use Output; - with Symbols; use Symbols; with Table; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; + procedure Gnatsym is Empty_String : aliased String := ""; @@ -82,8 +82,13 @@ procedure Gnatsym is Version_String : String_Access := Empty; -- The version of the library (used on VMS) + type Object_File_Data is record + Path : String_Access; + Name : String_Access; + end record; + package Object_Files is new Table.Table - (Table_Component_Type => String_Access, + (Table_Component_Type => Object_File_Data, Table_Index_Type => Natural, Table_Low_Bound => 0, Table_Initial => 10, @@ -164,7 +169,8 @@ procedure Gnatsym is end case; end loop; - -- Get the file names + -- Get the object file names and put them in the table in alphabetical + -- order of base names. loop declare @@ -175,7 +181,26 @@ procedure Gnatsym is exit when S'Length = 0; Object_Files.Increment_Last; - Object_Files.Table (Object_Files.Last) := S; + + declare + Base : constant String := Base_Name (S.all); + Last : constant Positive := Object_Files.Last; + J : Positive; + + begin + J := 1; + while J < Last loop + if Object_Files.Table (J).Name.all > Base then + Object_Files.Table (J + 1 .. Last) := + Object_Files.Table (J .. Last - 1); + exit; + end if; + + J := J + 1; + end loop; + + Object_Files.Table (J) := (S, new String'(Base)); + end; end; end loop; exception @@ -304,14 +329,16 @@ begin if Verbose then Write_Str ("Processing object file """); - Write_Str (Object_Files.Table (Object_File).all); + Write_Str (Object_Files.Table (Object_File).Path.all); Write_Line (""""); end if; - Processing.Process (Object_Files.Table (Object_File).all, Success); + Processing.Process + (Object_Files.Table (Object_File).Path.all, + Success); end loop; - -- Finalize the object file + -- Finalize the symbol file if Success then if Verbose then diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index 0a62a693839..684a3bb4d79 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -77,7 +77,7 @@ package Gnatvsn is -- value should never be decreased in the future, but it would be -- OK to increase it if absolutely necessary. - Library_Version : constant String := "4.5"; + Library_Version : constant String := "4.6"; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index 2cccc0f1f51..c20ef175564 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, 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- -- @@ -52,6 +52,9 @@ procedure Gnatxref is RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= switch + EXT_Specified : String_Access := null; + -- Used to detect multiple use of --ext= switch + procedure Parse_Cmd_Line; -- Parse every switch on the command line @@ -79,7 +82,7 @@ procedure Gnatxref is loop case GNAT.Command_Line.Getopt - ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS=") + ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS= -ext=") is when ASCII.NUL => exit; @@ -140,43 +143,70 @@ procedure Gnatxref is -- Check that it is the first time we see this switch - if RTS_Specified = null then - RTS_Specified := new String'(GNAT.Command_Line.Parameter); + if Full_Switch = "-RTS" then + if RTS_Specified = null then + RTS_Specified := new String'(GNAT.Command_Line.Parameter); - elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then - Osint.Fail ("--RTS cannot be specified multiple times"); - end if; + elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--RTS cannot be specified multiple times"); + end if; - Opt.No_Stdinc := True; - Opt.RTS_Switch := True; + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; - declare - Src_Path_Name : constant String_Ptr := - Get_RTS_Search_Dir - (GNAT.Command_Line.Parameter, Include); + declare + Src_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Include); - Lib_Path_Name : constant String_Ptr := - Get_RTS_Search_Dir - (GNAT.Command_Line.Parameter, Objects); + Lib_Path_Name : constant String_Ptr := + Get_RTS_Search_Dir + (GNAT.Command_Line.Parameter, + Objects); - begin - if Src_Path_Name /= null and then Lib_Path_Name /= null then - Add_Search_Dirs (Src_Path_Name, Include); - Add_Search_Dirs (Lib_Path_Name, Objects); + begin + if Src_Path_Name /= null + and then Lib_Path_Name /= null + then + Add_Search_Dirs (Src_Path_Name, Include); + Add_Search_Dirs (Lib_Path_Name, Objects); + + elsif Src_Path_Name = null + and then Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " & + "adainclude and adalib directories"); + + elsif Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adainclude directory"); - elsif Src_Path_Name = null and then Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude and adalib directories"); + elsif Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " & + "adalib directory"); + end if; + end; - elsif Src_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude directory"); + elsif GNAT.Command_Line.Full_Switch = "-ext" then - elsif Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adalib directory"); + -- Check that it is the first time we see this switch + + if EXT_Specified = null then + EXT_Specified := new String'(GNAT.Command_Line.Parameter); + + elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then + Osint.Fail ("--ext cannot be specified multiple times"); end if; - end; + + if EXT_Specified'Length + = Osint.ALI_Default_Suffix'Length + then + Osint.ALI_Suffix := EXT_Specified.all'Access; + else + Osint.Fail ("--ext argument must have 3 characters"); + end if; + end if; when others => Write_Usage; @@ -239,6 +269,7 @@ procedure Gnatxref is & " directory"); Put_Line (" -nostdlib Don't look for library files in the system" & " default directory"); + Put_Line (" --ext=xxx Specify alternate ali file extension"); Put_Line (" --RTS=dir specify the default source and object search" & " path"); Put_Line (" -p file Use file as the default project file"); diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads index 73258e76437..5c997bd75be 100644 --- a/gcc/ada/i-cstrea.ads +++ b/gcc/ada/i-cstrea.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -76,9 +76,9 @@ package Interfaces.C_Streams is -- Standard C functions -- -------------------------- - -- The functions selected below are ones that are available in DOS, - -- OS/2, UNIX and Xenix (but not necessarily in ANSI C). These are - -- very thin interfaces which copy exactly the C headers. For more + -- The functions selected below are ones that are available in + -- UNIX (but not necessarily in ANSI C). These are very thin + -- interfaces which copy exactly the C headers. For more -- documentation on these functions, see the Microsoft C "Run-Time -- Library Reference" (Microsoft Press, 1990, ISBN 1-55615-225-6), -- which includes useful information on system compatibility. diff --git a/gcc/ada/i-forbla-darwin.adb b/gcc/ada/i-forbla-darwin.adb index 2a2134ecba4..825a8840414 100644 --- a/gcc/ada/i-forbla-darwin.adb +++ b/gcc/ada/i-forbla-darwin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2010, 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- -- @@ -32,5 +32,7 @@ -- Version for Mac OS X package body Interfaces.Fortran.BLAS is + pragma Linker_Options ("-lgnala"); + pragma Linker_Options ("-lm"); pragma Linker_Options ("-Wl,-framework,vecLib"); end Interfaces.Fortran.BLAS; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 0f3ad5793ec..cbd489064ca 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, 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- -- @@ -173,6 +173,14 @@ package body Impunit is "a-wichun", -- Ada.Wide_Characters.Unicode "a-widcha", -- Ada.Wide_Characters + -- Note: strictly the next two should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 95 mode, since + -- they only deal with Wide_Character, not Wide_Wide_Character. + + "a-stuten", -- Ada.Strings.UTF_Encoding + "a-suenco", -- Ada.Strings.UTF_Encoding.Conversions + "a-suewen", -- Ada.Strings.UTF_Encoding.Wide_Encoding + --------------------------- -- GNAT Special IO Units -- --------------------------- @@ -250,6 +258,8 @@ package body Impunit is "g-io ", -- GNAT.IO "g-io_aux", -- GNAT.IO_Aux "g-locfil", -- GNAT.Lock_Files + "g-mbdira", -- GNAT.MBBS_Discrete_Random + "g-mbflra", -- GNAT.MBBS_Float_Random "g-md5 ", -- GNAT.MD5 "g-memdum", -- GNAT.Memory_Dump "g-moreex", -- GNAT.Most_Recent_Exception @@ -457,6 +467,11 @@ package body Impunit is "a-szuzti", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO "a-zchuni", -- Ada.Wide_Wide_Characters.Unicode + -- Note: strictly the following should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 2005 mode. + + "a-suezen", -- Ada.Strings.UTF_Encoding.Wide_Wide_Encoding + --------------------------- -- GNAT Special IO Units -- --------------------------- @@ -494,6 +509,8 @@ package body Impunit is -- Array of alternative unit names Scasuti : aliased String := "GNAT.Case_Util"; + Scrc32 : aliased String := "GNAT.CRC32"; + Shtable : aliased String := "GNAT.HTable"; Sos_lib : aliased String := "GNAT.OS_Lib"; Sregexp : aliased String := "GNAT.Regexp"; Sregpat : aliased String := "GNAT.Regpat"; @@ -504,8 +521,10 @@ package body Impunit is -- Array giving mapping - Map_Array : constant array (1 .. 8) of Aunit_Record := ( + Map_Array : constant array (1 .. 10) of Aunit_Record := ( ("casuti", Scasuti'Access), + ("crc32 ", Scrc32 'Access), + ("htable", Shtable'Access), ("os_lib", Sos_lib'Access), ("regexp", Sregexp'Access), ("regpat", Sregpat'Access), @@ -609,12 +628,17 @@ package body Impunit is Get_Name_String (Fname); - if Name_Len = 12 + if Name_Len in 11 .. 12 and then Name_Buffer (1 .. 2) = "s-" - and then Name_Buffer (9 .. 12) = ".ads" + and then Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" then for J in Map_Array'Range loop - if Name_Buffer (3 .. 8) = Map_Array (J).Fname then + if (Name_Len = 12 and then + Name_Buffer (3 .. 8) = Map_Array (J).Fname) + or else + (Name_Len = 11 and then + Name_Buffer (3 .. 7) = Map_Array (J).Fname (1 .. 5)) + then Error_Msg_Strlen := Map_Array (J).Aname'Length; Error_Msg_String (1 .. Error_Msg_Strlen) := Map_Array (J).Aname.all; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index ad4928d8276..f011668899c 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, 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- * @@ -1568,15 +1568,18 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) #endif -/* Feature logical name and global variable address pair */ +/* Feature logical name and global variable address pair. + If we ever add another feature logical to this list, the + feature struct will need to be enhanced to take into account + possible values for *gl_addr. */ struct feature {char *name; int* gl_addr;}; /* Default values for GNAT features set by environment. */ -int __gl_no_malloc_64 = 0; +int __gl_heap_size = 64; /* Array feature logical names and global variable addresses */ static struct feature features[] = { - {"GNAT$NO_MALLOC_64", &__gl_no_malloc_64}, + {"GNAT$NO_MALLOC_64", &__gl_heap_size}, {0, 0} }; @@ -1607,10 +1610,14 @@ void __gnat_set_features () else strcpy (buff, ""); - if (strcmp (buff, "ENABLE") == 0) - *features [i].gl_addr = 1; - else if (strcmp (buff, "DISABLE") == 0) - *features [i].gl_addr = 0; + if ((strcmp (buff, "ENABLE") == 0) || + (strcmp (buff, "TRUE") == 0) || + (strcmp (buff, "1") == 0)) + *features [i].gl_addr = 32; + else if ((strcmp (buff, "DISABLE") == 0) || + (strcmp (buff, "FALSE") == 0) || + (strcmp (buff, "0") == 0)) + *features [i].gl_addr = 64; } __gnat_features_set = 1; @@ -2211,10 +2218,10 @@ __gnat_install_handler (void) /*********************/ /* This routine is called as each process thread is created, for possible - initialization of the FP processor. This version is used under INTERIX, - WIN32 and could be used under OS/2. */ + initialization of the FP processor. This version is used under INTERIX + and WIN32. */ -#if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \ +#if defined (_WIN32) || defined (__INTERIX) \ || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__) \ || defined (__OpenBSD__) diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index eeeb9da9106..1379a9e82dd 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -34,7 +34,6 @@ with Fname.UF; use Fname.UF; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; -with Opt; use Opt; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index fec948d6941..04cb3234400 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -36,6 +36,7 @@ -- Frontend, and thus are not mutually recursive. with Alloc; +with Opt; use Opt; with Sem; use Sem; with Table; with Types; use Types; @@ -84,6 +85,10 @@ package Inline is -- This means we have to capture this information from the current scope -- at the point of instantiation. + Version : Ada_Version_Type; + -- The body must be compiled with the same language version as the + -- spec. The version may be set by a configuration pragma in a separate + -- file or in the current file, and may differ from body to body. end record; package Pending_Instantiations is new Table.Table ( diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads index 0d70c1d382d..ffd3a1d496e 100644 --- a/gcc/ada/itypes.ads +++ b/gcc/ada/itypes.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -127,7 +127,7 @@ package Itypes is -- If the implicit type does not need an external name, then the -- Related_Id parameter is omitted (and hence Empty). In this case -- Suffix and Suffix_Index are ignored and the implicit type name is - -- created by a call to New_Internal_Name ('T'). + -- created by a call to Make_Temporary. -- -- Note that in all cases, the name starts with "T". This is used -- to identify implicit types in the error message handling circuits. diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 69772d69290..be2bd802317 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -2560,10 +2560,10 @@ package body Layout is begin -- For some reasons, access types can cause trouble, So let's - -- just do this for discrete types ??? + -- just do this for scalar types ??? if Present (CT) - and then Is_Discrete_Type (CT) + and then Is_Scalar_Type (CT) and then Known_Static_Esize (CT) then declare @@ -2736,8 +2736,7 @@ package body Layout is begin if Spec < Min then Error_Msg_Uint_1 := Min; - Error_Msg_NE - ("size for & too small, minimum allowed is ^", SC, E); + Error_Msg_NE ("size for & too small, minimum allowed is ^", SC, E); Init_Esize (E); Init_RM_Size (E); end if; @@ -3119,11 +3118,7 @@ package body Layout is Make_Func : Boolean := False) return Dynamic_SO_Ref is Loc : constant Source_Ptr := Sloc (Ins_Type); - - K : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('K')); - + K : constant Entity_Id := Make_Temporary (Loc, 'K'); Decl : Node_Id; Vtype_Primary_View : Entity_Id; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index b3207c1b398..54514325229 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -610,8 +610,8 @@ package Lib.Writ is --------------------- -- The reference lines contain information about references from any of the - -- units in the compilation (including, body version and version - -- attributes, linker options pragmas and source dependencies. + -- units in the compilation (including body version and version attributes, + -- linker options pragmas and source dependencies). -- ------------------------------------ -- -- E External Version References -- @@ -696,14 +696,13 @@ package Lib.Writ is -- reference data. See the spec of Par_SCO for full details of the format. ---------------------- - -- Global_Variables -- + -- Global Variables -- ---------------------- - -- The table structure defined here stores one entry for each - -- Interrupt_State pragma encountered either in the main source or - -- in an ancillary with'ed source. Since interrupt state values - -- have to be consistent across all units in a partition, we may - -- as well detect inconsistencies at compile time when we can. + -- The table defined here stores one entry for each Interrupt_State pragma + -- encountered either in the main source or in an ancillary with'ed source. + -- Since interrupt state values have to be consistent across all units in a + -- partition, we detect inconsistencies at compile time when we can. type Interrupt_State_Entry is record Interrupt_Number : Pos; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 516fc55261f..5283023a856 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, 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- -- @@ -214,7 +214,6 @@ package body Lib.Xref is Base_T : Entity_Id; Prim : Elmt_Id; Prim_List : Elist_Id; - Ent : Entity_Id; begin -- Handle subtypes of synchronized types @@ -262,12 +261,8 @@ package body Lib.Xref is -- reference purposes (it is the original for which we want the xref -- and for which the comes_from_source test must be performed). - Ent := Node (Prim); - while Present (Alias (Ent)) loop - Ent := Alias (Ent); - end loop; - - Generate_Reference (Typ, Ent, 'p', Set_Ref => False); + Generate_Reference + (Typ, Ultimate_Alias (Node (Prim)), 'p', Set_Ref => False); Next_Elmt (Prim); end loop; end Generate_Prim_Op_References; @@ -666,7 +661,7 @@ package body Lib.Xref is -- Check for pragma Unreferenced given and reference is within -- this source unit (occasion for possible warning to be issued). - if Has_Pragma_Unreferenced (E) + if Has_Unreferenced (E) and then In_Same_Extended_Unit (E, N) then -- A reference as a named parameter in a call does not count @@ -699,7 +694,7 @@ package body Lib.Xref is BE := First_Entity (Current_Scope); while Present (BE) loop if Chars (BE) = Chars (E) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?pragma Unreferenced given for&!", N, BE); exit; end if; @@ -711,7 +706,8 @@ package body Lib.Xref is -- Here we issue the warning, since this is a real reference else - Error_Msg_NE ("?pragma Unreferenced given for&!", N, E); + Error_Msg_NE -- CODEFIX + ("?pragma Unreferenced given for&!", N, E); end if; end if; @@ -1703,10 +1699,7 @@ package body Lib.Xref is -- through several levels of derivation, so find the -- ultimate (source) ancestor. - Op := Alias (Old_E); - while Present (Alias (Op)) loop - Op := Alias (Op); - end loop; + Op := Ultimate_Alias (Old_E); -- Normal case of no alias present diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 0e3c85765d5..d1cafbf32d3 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -202,6 +202,14 @@ package body Make is Unique_Compile_All_Projects : Boolean := False; -- Set to True if -U is used + Must_Compile : Boolean := False; + -- True if gnatmake is invoked with -f -u and one or several mains on the + -- command line. + + Main_On_Command_Line : Boolean := False; + -- True if gnatmake is invoked with one or several mains on the command + -- line. + RTS_Specified : String_Access := null; -- Used to detect multiple --RTS= switches @@ -1387,7 +1395,7 @@ package body Make is if Project_Of_Current_Object_Directory /= Project then Project_Of_Current_Object_Directory := Project; - Object_Directory := Project.Object_Directory.Name; + Object_Directory := Project.Object_Directory.Display_Name; -- Set the working directory to the object directory of the actual -- project. @@ -1785,6 +1793,13 @@ package body Make is Modified_Source := Time_Stamp_Mismatch (ALI, Read_Only); + -- To avoid using too much memory when switch -m is used, free the + -- memory allocated for the source file when computing the checksum. + + if Minimal_Recompilation then + Sinput.P.Clear_Source_File_Table; + end if; + if Modified_Source /= No_File then ALI := No_ALI_Id; @@ -2236,12 +2251,14 @@ package body Make is if Arguments_Project = No_Project then Add_Arguments (The_Saved_Gcc_Switches.all); - elsif not Arguments_Project.Externally_Built then + elsif not Arguments_Project.Externally_Built + or else Must_Compile + then -- We get the project directory for the relative path -- switches and arguments. - Arguments_Project := Ultimate_Extending_Project_Of - (Arguments_Project); + Arguments_Project := + Ultimate_Extending_Project_Of (Arguments_Project); -- If building a dynamic or relocatable library, compile with -- PIC option, if it exists. @@ -2251,7 +2268,6 @@ package body Make is then declare PIC : constant String := MLib.Tgt.PIC_Option; - begin if PIC /= "" then Add_Arguments ((1 => new String'(PIC))); @@ -2432,7 +2448,7 @@ package body Make is -- Info on the mapping file Need_To_Check_Standard_Library : Boolean := - Check_Readonly_Files + (Check_Readonly_Files or Must_Compile) and not Unique_Compile; procedure Add_Process @@ -2719,11 +2735,14 @@ package body Make is -- check for an eventual library project, and use the full path. if Arguments_Project /= No_Project then - if not Arguments_Project.Externally_Built then + if not Arguments_Project.Externally_Built + or else Must_Compile + then Prj.Env.Set_Ada_Paths (Arguments_Project, Project_Tree, - Including_Libraries => True); + Including_Libraries => True, + Include_Path => Use_Include_Path_File); if not Unique_Compile and then MLib.Tgt.Support_For_Libraries /= Prj.None @@ -2734,7 +2753,7 @@ package body Make is begin if Prj.Library - and then not Prj.Externally_Built + and then (not Prj.Externally_Built or else Must_Compile) and then not Prj.Need_To_Build_Lib then -- Add to the Q all sources of the project that have @@ -2886,7 +2905,7 @@ package body Make is begin if Is_Predefined_File_Name (Fname, False) then - if Check_Readonly_Files then + if Check_Readonly_Files or else Must_Compile then Comp_Args (Comp_Args'First + 2 .. Comp_Last + 1) := Comp_Args (Comp_Args'First + 1 .. Comp_Last); Comp_Last := Comp_Last + 1; @@ -3084,7 +3103,7 @@ package body Make is if Is_Marked (Sfile, Source_Index) then Debug_Msg ("Skipping marked file:", Sfile); - elsif not Check_Readonly_Files + elsif not (Check_Readonly_Files or Must_Compile) and then Is_Internal_File_Name (Sfile, False) then Debug_Msg ("Skipping internal file:", Sfile); @@ -3265,14 +3284,14 @@ package body Make is end if; In_Lib_Dir := Full_Lib_File /= No_File - and then In_Ada_Lib_Dir (Full_Lib_File); + and then In_Ada_Lib_Dir (Full_Lib_File); -- Since the following requires a system call, we precompute it -- when needed. if not In_Lib_Dir then if Full_Lib_File /= No_File - and then not Check_Readonly_Files + and then not (Check_Readonly_Files or else Must_Compile) then Get_Name_String (Full_Lib_File); Name_Buffer (Name_Len + 1) := ASCII.NUL; @@ -3314,7 +3333,7 @@ package body Make is -- Source and library files can be located but are internal -- files. - elsif not Check_Readonly_Files + elsif not (Check_Readonly_Files or else Must_Compile) and then Full_Lib_File /= No_File and then Is_Internal_File_Name (Source_File, False) then @@ -3342,6 +3361,7 @@ package body Make is if Arguments_Project = No_Project or else not Arguments_Project.Externally_Built + or else Must_Compile then -- Don't waste any time if we have to recompile anyway @@ -4731,13 +4751,6 @@ package body Make is Display_Version ("GNATMAKE", "1995"); end if; - if Main_Project /= No_Project - and then Main_Project.Externally_Built - then - Make_Failed - ("nothing to do for a main project that is externally built"); - end if; - if Osint.Number_Of_Files = 0 then if Main_Project /= No_Project and then Main_Project.Library @@ -5174,6 +5187,25 @@ package body Make is end; end if; + -- The combination of -f -u and one or several mains on the command line + -- implies -a. + + if Force_Compilations + and then Unique_Compile + and then not Unique_Compile_All_Projects + and then Main_On_Command_Line + then + Must_Compile := True; + end if; + + if Main_Project /= No_Project + and then not Must_Compile + and then Main_Project.Externally_Built + then + Make_Failed + ("nothing to do for a main project that is externally built"); + end if; + -- Get the target parameters, which are only needed for a couple of -- cases in gnatmake. Protect against an exception, such as the case of -- system.ads missing from the library, and fail gracefully. @@ -6026,7 +6058,8 @@ package body Make is -- and all the object directories in ADA_OBJECTS_PATH, -- except those of library projects. - Prj.Env.Set_Ada_Paths (Main_Project, Project_Tree, False); + Prj.Env.Set_Ada_Paths + (Main_Project, Project_Tree, Use_Include_Path_File); -- If switch -C was specified, create a binder mapping file @@ -6043,7 +6076,7 @@ package body Make is exception when others => - -- Delete the temporary mapping file, if one was created. + -- Delete the temporary mapping file if one was created if Mapping_Path /= No_Path then Delete_Temporary_File (Project_Tree, Mapping_Path); @@ -6054,7 +6087,7 @@ package body Make is raise; end; - -- If -dn was not specified, delete the temporary mapping file, + -- If -dn was not specified, delete the temporary mapping file -- if one was created. if Mapping_Path /= No_Path then @@ -6253,7 +6286,11 @@ package body Make is -- Put the object directories in ADA_OBJECTS_PATH - Prj.Env.Set_Ada_Paths (Main_Project, Project_Tree, False); + Prj.Env.Set_Ada_Paths + (Main_Project, + Project_Tree, + Including_Libraries => False, + Include_Path => False); -- Check for attributes Linker'Linker_Options in projects -- other than the main project @@ -8174,13 +8211,11 @@ package body Make is elsif Argv (2 .. Argv'Last) = "nostdlib" then - -- Don't pass -nostdlib to gnatlink, it will disable - -- linking with all standard library files. + -- Pass -nstdlib to gnatbind and gnatlink No_Stdlib := True; - - Add_Switch (Argv, Compiler, And_Save => And_Save); Add_Switch (Argv, Binder, And_Save => And_Save); + Add_Switch (Argv, Linker, And_Save => And_Save); elsif Argv (2 .. Argv'Last) = "nostdinc" then @@ -8206,6 +8241,10 @@ package body Make is -- If not a switch it must be a file name else + if And_Save then + Main_On_Command_Line := True; + end if; + Add_File (Argv); Mains.Add_Main (Argv); end if; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index ca22dceec9c..7f8ddb6163d 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,8 +23,9 @@ -- -- ------------------------------------------------------------------------------ -with Osint; use Osint; -with Output; use Output; +with Makeutl; +with Osint; use Osint; +with Output; use Output; with Usage; procedure Makeusg is @@ -311,6 +312,14 @@ begin Write_Str (" --subdirs=dir real obj/lib/exec dirs are subdirs"); Write_Eol; + + -- Line for --unchecked-shared-lib-imports + + Write_Str (" "); + Write_Str (Makeutl.Unchecked_Shared_Lib_Imports); + Write_Eol; + Write_Str (" Allow shared libraries to import static libraries"); + Write_Eol; Write_Eol; -- General Compiler, Binder, Linker switches diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index ab00b506578..e07bebbad6b 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, 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- -- @@ -26,6 +26,7 @@ with ALI; use ALI; with Debug; with Fname; +with Hostparm; with Osint; use Osint; with Output; use Output; with Opt; use Opt; @@ -38,8 +39,8 @@ with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with System.Case_Util; use System.Case_Util; -with System.HTable; +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.HTable; package body Makeutl is @@ -58,7 +59,7 @@ package body Makeutl is function Hash (Key : Mark_Key) return Mark_Num; - package Marks is new System.HTable.Simple_HTable + package Marks is new GNAT.HTable.Simple_HTable (Header_Num => Mark_Num, Element => Boolean, No_Element => False, @@ -378,6 +379,12 @@ package body Makeutl is -- Beginning of Executable_Prefix_Path begin + -- For VMS, the path returned is always /gnu/ + + if Hostparm.OpenVMS then + return "/gnu/"; + end if; + -- First determine if a path prefix was placed in front of the -- executable name. diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index a7614f399c4..fd286a8ebcc 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2010, 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- -- @@ -47,6 +47,11 @@ package Makeutl is -- Switch used to indicate that the real directories (object, exec, -- library, ...) are subdirectories of those in the project file. + Unchecked_Shared_Lib_Imports : constant String := + "--unchecked-shared-lib-imports"; + -- Command line switch to allow shared library projects to import projects + -- that are not shared library projects. + procedure Add (Option : String_Access; To : in out String_List_Access; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb index f15b7c06d27..97a4c16180f 100644 --- a/gcc/ada/mlib-prj.adb +++ b/gcc/ada/mlib-prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2010, 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- -- @@ -2285,6 +2285,11 @@ package body MLib.Prj is for Index in 1 .. Argument_Number loop Write_Char (' '); Write_Str (Arguments (Index).all); + + if not Opt.Verbose_Mode and then Index > 4 then + Write_Str (" ..."); + exit; + end if; end loop; Write_Eol; diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb index 78378a673b9..67e03097ed6 100644 --- a/gcc/ada/mlib-utl.adb +++ b/gcc/ada/mlib-utl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2008, AdaCore -- +-- Copyright (C) 2002-2010, 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- -- @@ -460,11 +460,25 @@ package body MLib.Utl is end loop; if not Opt.Quiet_Output then - Write_Str (Driver.all); + if Opt.Verbose_Mode then + Write_Str (Driver.all); + + elsif Driver_Name /= No_Name then + Write_Str (Get_Name_String (Driver_Name)); + + else + Write_Str (Gcc_Name.all); + end if; for J in 1 .. A loop - Write_Char (' '); - Write_Str (Arguments (J).all); + if Opt.Verbose_Mode or else J < 4 then + Write_Char (' '); + Write_Str (Arguments (J).all); + + else + Write_Str (" ..."); + exit; + end if; end loop; -- Do not display all the object files if not in verbose mode, only @@ -480,10 +494,19 @@ package body MLib.Utl is elsif Position = Second then Write_Str (" ..."); Position := Last; + exit; end if; end loop; for J in Options_2'Range loop + if not Opt.Verbose_Mode then + if Position = Second then + Write_Str (" ..."); + end if; + + exit; + end if; + Write_Char (' '); Write_Str (Options_2 (J).all); end loop; diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 09bd85a8439..fe4d27c24c4 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -1055,6 +1055,77 @@ package body Nlists is Set_List_Link (Node, To); end Prepend; + ------------------ + -- Prepend_List -- + ------------------ + + procedure Prepend_List (List : List_Id; To : List_Id) is + + procedure Prepend_List_Debug; + pragma Inline (Prepend_List_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------------ + -- Prepend_List_Debug -- + ------------------------ + + procedure Prepend_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Prepend list "); + Write_Int (Int (List)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Prepend_List_Debug; + + -- Start of processing for Prepend_List + + begin + if Is_Empty_List (List) then + return; + + else + declare + F : constant Node_Id := First (To); + L : constant Node_Id := Last (List); + N : Node_Id; + + begin + pragma Debug (Prepend_List_Debug); + + N := L; + loop + Set_List_Link (N, To); + N := Prev (N); + exit when No (N); + end loop; + + if No (F) then + Set_Last (To, L); + else + Set_Next (L, F); + end if; + + Set_Prev (F, L); + Set_First (To, First (List)); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Prepend_List; + + --------------------- + -- Prepend_List_To -- + --------------------- + + procedure Prepend_List_To (To : List_Id; List : List_Id) is + begin + Prepend_List (List, To); + end Prepend_List_To; + ---------------- -- Prepend_To -- ---------------- diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 3753936df10..cecf3a21db4 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -259,6 +259,14 @@ package Nlists is pragma Inline (Prepend_To); -- Like Prepend, but arguments are the other way round + procedure Prepend_List (List : List_Id; To : List_Id); + -- Prepends node list List to the start of node list To. On return, + -- List is reset to be empty. + + procedure Prepend_List_To (To : List_Id; List : List_Id); + pragma Inline (Prepend_List_To); + -- Like Prepend_List, but arguments are the other way round + procedure Remove (Node : Node_Id); -- Removes Node, which must be a node that is a member of a node list, -- from this node list. The contents of Node are not otherwise affected. diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index a1528962b01..65c5726b901 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 90b44599edd..54cec4932d6 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,8 +41,11 @@ with Hostparm; use Hostparm; with Types; use Types; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.Strings; use System.Strings; with System.WCh_Con; use System.WCh_Con; +pragma Warnings (On); package Opt is @@ -61,17 +64,15 @@ package Opt is -- GNATBIND, GNATLINK -- Set True if binder file to be generated in Ada rather than C - type Ada_Version_Type is (Ada_83, Ada_95, Ada_05); - pragma Warnings (Off, Ada_Version_Type); + type Ada_Version_Type is (Ada_83, Ada_95, Ada_05, Ada_12); -- Versions of Ada for Ada_Version below. Note that these are ordered, -- so that tests like Ada_Version >= Ada_95 are legitimate and useful. - -- The Warnings_Off pragma stops warnings for Ada_Version >= Ada_05, - -- which we want to allow, so that things work OK when Ada_15 is added! - -- This warning is now removed, so this pragma can be removed some time??? - Ada_Version_Default : Ada_Version_Type := Ada_05; + Ada_Version_Default : constant Ada_Version_Type := Ada_05; + pragma Warnings (Off, Ada_Version_Default); -- GNAT - -- Default Ada version if no switch given + -- Default Ada version if no switch given. The Warnings off is to kill + -- constant condition warnings. Ada_Version : Ada_Version_Type := Ada_Version_Default; -- GNAT @@ -88,7 +89,7 @@ package Opt is -- the rare cases (notably for pragmas Preelaborate_05 and Pure_05) -- where in the run-time we want the explicit version set. - Ada_Version_Runtime : Ada_Version_Type := Ada_05; + Ada_Version_Runtime : Ada_Version_Type := Ada_12; -- GNAT -- Ada version used to compile the runtime. Used to set Ada_Version (but -- not Ada_Version_Explicit) when compiling predefined or internal units. @@ -172,6 +173,15 @@ package Opt is -- also set true if certain Unchecked_Conversion instantiations require -- checking based on annotated values. + Back_End_Handles_Limited_Types : Boolean; + -- This flag is set true if the back end can properly handle limited or + -- other by reference types, and avoid copies. If this flag is False, then + -- the front end does special expansion for conditional expressions to make + -- sure that no copy occurs. If the flag is True, then the expansion for + -- conditional expressions relies on the back end properly handling things. + -- Currently the default is False for all cases (set in gnat1drv). The + -- default can be modified using -gnatd.L (sets the flag True). + Bind_Alternate_Main_Name : Boolean := False; -- GNATBIND -- True if main should be called Alternate_Main_Name.all. @@ -453,8 +463,8 @@ package Opt is Front_End_Setjmp_Longjmp_Exceptions; -- GNAT -- Set to the appropriate value depending on the default as given in - -- system.ads (ZCX_By_Default, GCC_ZCX_Support). - -- The C convention is there to make this variable accessible to gigi. + -- system.ads (ZCX_By_Default, GCC_ZCX_Support). The C convention is there + -- to make this variable accessible to gigi. Exception_Tracebacks : Boolean := False; -- GNATBIND @@ -573,6 +583,11 @@ package Opt is -- GNAT -- True if compiling in GNAT system mode (-gnatg switch) + Heap_Size : Nat := 0; + -- GNATBIND + -- Heap size for memory allocations. Valid values are 32 and 64. Only + -- available on VMS. + HLO_Active : Boolean := False; -- GNAT -- True if High Level Optimizer is activated (-gnatH switch) @@ -942,9 +957,17 @@ package Opt is -- GNATBIND -- True if output of list of linker options is requested (-K switch set) - Output_Object_List : Boolean := False; + Output_ALI_List : Boolean := False; + ALI_List_Filename : String_Ptr; + -- GNATBIND + -- True if output of list of ALIs is requested (-A switch set). List is + -- output under the given filename, or standard output if not specified. + + Output_Object_List : Boolean := False; + Object_List_Filename : String_Ptr; -- GNATBIND - -- True if output of list of objects is requested (-O switch set) + -- True if output of list of objects is requested (-O switch set). List is + -- output under the given filename, or standard output if not specified. Overflow_Checks_Unsuppressed : Boolean := False; -- GNAT @@ -1229,11 +1252,23 @@ package Opt is -- set True, and upper half characters in the source indicate the start of -- a wide character sequence. Set by -gnatW or -W switches. + Use_Include_Path_File : Boolean := False; + -- GNATMAKE, GPRBUILD + -- When True, create a source search path file, even when a mapping file + -- is used. + Usage_Requested : Boolean := False; -- GNAT, GNATBIND, GNATMAKE -- Set to True if -h (-gnath for the compiler) switch encountered -- requesting usage information + Use_Expression_With_Actions : Boolean; + -- The N_Expression_With_Actions node has been introduced relatively + -- recently, and not all back ends are prepared to handle it yet. So + -- we use this flag to suppress its use during a transitional period. + -- Currently the default is False for all cases (set in gnat1drv). + -- The default can be modified using -gnatd.X/-gnatd.Y. + Use_Pragma_Linker_Constructor : Boolean := False; -- GNATBIND -- True if pragma Linker_Constructor applies to adainit diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb index b66cebf2ac2..39b7a99be84 100644 --- a/gcc/ada/osint-b.adb +++ b/gcc/ada/osint-b.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,10 +24,13 @@ ------------------------------------------------------------------------------ with Opt; use Opt; +with Output; use Output; with Targparm; use Targparm; package body Osint.B is + Current_List_File : File_Descriptor := Invalid_FD; + ------------------------- -- Close_Binder_Output -- ------------------------- @@ -45,6 +48,19 @@ package body Osint.B is end Close_Binder_Output; + --------------------- + -- Close_List_File -- + --------------------- + + procedure Close_List_File is + begin + if Current_List_File /= Invalid_FD then + Close (Current_List_File); + Current_List_File := Invalid_FD; + Set_Standard_Output; + end if; + end Close_List_File; + -------------------------- -- Create_Binder_Output -- -------------------------- @@ -65,8 +81,8 @@ package body Osint.B is begin if Output_File_Name /= "" then - Name_Buffer (Output_File_Name'Range) := Output_File_Name; - Name_Buffer (Output_File_Name'Last + 1) := ASCII.NUL; + Name_Buffer (1 .. Output_File_Name'Length) := Output_File_Name; + Name_Buffer (Output_File_Name'Length + 1) := ASCII.NUL; if Typ = 's' then Name_Buffer (Output_File_Name'Last) := 's'; @@ -176,6 +192,22 @@ package body Osint.B is Current_File_Name_Index := To; end Set_Current_File_Name_Index; + ------------------- + -- Set_List_File -- + ------------------- + + procedure Set_List_File (Filename : String) is + begin + pragma Assert (Current_List_File = Invalid_FD); + Current_List_File := Create_File (Filename, Text); + + if Current_List_File = Invalid_FD then + Fail ("cannot create list file: " & Filename); + else + Set_Output (Current_List_File); + end if; + end Set_List_File; + ----------------------- -- Write_Binder_Info -- ----------------------- diff --git a/gcc/ada/osint-b.ads b/gcc/ada/osint-b.ads index a6b601fd296..d24ec91ee21 100644 --- a/gcc/ada/osint-b.ads +++ b/gcc/ada/osint-b.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -44,9 +44,9 @@ package Osint.B is -- Binder Output -- ------------------- - -- These routines are used by the binder to generate the C source file - -- containing the binder output. The format of this file is described - -- in the package Bindfmt. + -- These routines are used by the binder to generate the C or Ada source + -- files containing the binder output. The format of these files is + -- described in package Bindgen. procedure Create_Binder_Output (Output_File_Name : String; @@ -81,4 +81,16 @@ package Osint.B is procedure Set_Current_File_Name_Index (To : Int); -- Set value of Current_File_Name_Index (in private part of Osint) to To + ---------------------------------- + -- Other binder-generated files -- + ---------------------------------- + + procedure Set_List_File (Filename : String); + -- Create Filename as a text output file and set it as the current output + -- (see Output.Set_Output). + + procedure Close_List_File; + -- If a specific output file was created by Set_List_File, close it and + -- reset the current output file to standard output. + end Osint.B; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 6265ede68d1..75995e3fca4 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,23 +23,26 @@ -- -- ------------------------------------------------------------------------------ +with Alloc; +with Debug; +with Fmap; use Fmap; +with Gnatvsn; use Gnatvsn; +with Hostparm; +with Opt; use Opt; +with Output; use Output; +with Sdefault; use Sdefault; +with Table; +with Targparm; use Targparm; + with Unchecked_Conversion; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.Case_Util; use System.Case_Util; +pragma Warnings (On); with GNAT.HTable; -with Alloc; -with Debug; -with Fmap; use Fmap; -with Gnatvsn; use Gnatvsn; -with Hostparm; -with Opt; use Opt; -with Output; use Output; -with Sdefault; use Sdefault; -with Table; -with Targparm; use Targparm; - package body Osint is Running_Program : Program_Type := Unspecified; @@ -538,7 +541,11 @@ package body Osint is end loop; end if; - if not Opt.No_Stdlib and not Opt.RTS_Switch then + -- Even when -nostdlib is used, we still want to have visibility on + -- the run-time object directory, as it is used by gnatbind to find + -- the run-time ALI files in "real" ZFP set up. + + if not Opt.RTS_Switch then Search_Path := Read_Default_Search_Dirs (String_Access (Update_Path (Search_Dir_Prefix)), diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index ae827ba286b..a1d9d05d4c4 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,19 +29,23 @@ with Namet; use Namet; with Types; use Types; -with System.Storage_Elements; -with System.OS_Lib; use System.OS_Lib; with System; use System; +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + +with System.Storage_Elements; + pragma Elaborate_All (System.OS_Lib); -- For the call to function Get_Target_Object_Suffix in the private part package Osint is Multi_Unit_Index_Character : Character := '~'; - -- The character before the index of the unit in a multi-unit source, in - -- ALI and object file names. This is not a constant, because it is changed - -- to '$' on VMS. + -- The character before the index of the unit in a multi-unit source in ALI + -- and object file names. Changed to '$' on VMS. Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; @@ -80,7 +84,7 @@ package Osint is Get_File_Names_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case - -- sensitive (e.g., in OS/2, set False). + -- sensitive (e.g., in Windows, set False). procedure Canonical_Case_File_Name (S : in out String); -- Given a file name, converts it to canonical case form. For systems diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index 141c12fb294..8210d3f258f 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with System.OS_Lib; use System.OS_Lib; - package body Output is Current_FD : File_Descriptor := Standout; @@ -228,17 +226,26 @@ package body Output is Special_Output_Proc := P; end Set_Special_Output; - ------------------------ - -- Set_Standard_Error -- - ------------------------ + ---------------- + -- Set_Output -- + ---------------- - procedure Set_Standard_Error is + procedure Set_Output (FD : File_Descriptor) is begin if Special_Output_Proc = null then Flush_Buffer; end if; - Current_FD := Standerr; + Current_FD := FD; + end Set_Output; + + ------------------------ + -- Set_Standard_Error -- + ------------------------ + + procedure Set_Standard_Error is + begin + Set_Output (Standerr); end Set_Standard_Error; ------------------------- @@ -247,11 +254,7 @@ package body Output is procedure Set_Standard_Output is begin - if Special_Output_Proc = null then - Flush_Buffer; - end if; - - Current_FD := Standout; + Set_Output (Standout); end Set_Standard_Output; ------- diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 7f13dc24b15..ddc395448d3 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,42 +29,46 @@ -- -- ------------------------------------------------------------------------------ --- This package contains low level output routines used by the compiler --- for writing error messages and informational output. It is also used --- by the debug source file output routines (see Sprintf.Print_Eol). +-- This package contains low level output routines used by the compiler for +-- writing error messages and informational output. It is also used by the +-- debug source file output routines (see Sprint.Print_Debug_Line). with Hostparm; use Hostparm; with Types; use Types; +pragma Warnings (Off); +-- This package is used also by gnatcoll +with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + package Output is pragma Elaborate_Body; type Output_Proc is access procedure (S : String); - -- This type is used for the Set_Special_Output procedure. If this - -- procedure is called, then instead of lines being written to - -- standard error or standard output, a call is made to the given - -- procedure for each line, passing the line with an end of line - -- character (which is a single ASCII.LF character, even in systems - -- which normally use CR/LF or some other sequence for line end). + -- This type is used for the Set_Special_Output procedure. If Output_Proc + -- is called, then instead of lines being written to standard error or + -- standard output, a call is made to the given procedure for each line, + -- passing the line with an end of line character (which is a single + -- ASCII.LF character, even in systems which normally use CR/LF or some + -- other sequence for line end). ----------------- -- Subprograms -- ----------------- procedure Set_Special_Output (P : Output_Proc); - -- Sets subsequent output to call procedure P. If P is null, then - -- the call cancels the effect of a previous call, reverting the - -- output to standard error or standard output depending on the - -- mode at the time of previous call. Any exception generated by - -- by calls to P is simply propagated to the caller of the routine - -- causing the write operation. + -- Sets subsequent output to call procedure P. If P is null, then the call + -- cancels the effect of a previous call, reverting the output to standard + -- error or standard output depending on the mode at the time of previous + -- call. Any exception generated by by calls to P is simply propagated to + -- the caller of the routine causing the write operation. procedure Cancel_Special_Output; - -- Cancels the effect of a call to Set_Special_Output, if any. - -- The output is then directed to standard error or standard output - -- depending on the last call to Set_Standard_Error or Set_Standard_Output. - -- It is never an error to call Cancel_Special_Output. It has the same - -- effect as calling Set_Special_Output (null). + -- Cancels the effect of a call to Set_Special_Output, if any. The output + -- is then directed to standard error or standard output depending on the + -- last call to Set_Standard_Error or Set_Standard_Output. It is never an + -- error to call Cancel_Special_Output. It has the same effect as calling + -- Set_Special_Output (null). procedure Ignore_Output (S : String); -- Does nothing. To disable output, pass Ignore_Output'Access to @@ -79,11 +83,17 @@ package Output is procedure Set_Standard_Output; -- Sets subsequent output to appear on the standard output file (whatever - -- that might mean for the host operating system, if anything) when - -- no special output is in effect. When a special output is in effect, - -- the output will appear on standard output only after special output - -- has been cancelled. Output to standard output is the default mode - -- before any call to either of the Set procedures. + -- that might mean for the host operating system, if anything) when no + -- special output is in effect. When a special output is in effect, the + -- output will appear on standard output only after special output has been + -- cancelled. Output to standard output is the default mode before any call + -- to either of the Set procedures. + + procedure Set_Output (FD : File_Descriptor); + -- Sets subsequent output to appear on the given file descriptor when no + -- special output is in effect. When a special output is in effect, the + -- output will appear on the given file descriptor only after special + -- output has been cancelled. procedure Indent; -- Increases the current indentation level. Whenever a line is written @@ -101,36 +111,36 @@ package Output is -- If last character in buffer matches C, erase it, otherwise no effect procedure Write_Eol; - -- Write an end of line (whatever is required by the system in use, - -- e.g. CR/LF for DOS, or LF for Unix) to the standard output file. - -- This routine also empties the line buffer, actually writing it - -- to the file. Note that Write_Eol is the only routine that causes - -- any actual output to be written. Trailing spaces are removed. + -- Write an end of line (whatever is required by the system in use, e.g. + -- CR/LF for DOS, or LF for Unix) to the standard output file. This routine + -- also empties the line buffer, actually writing it to the file. Note that + -- Write_Eol is the only routine that causes any actual output to be + -- written. Trailing spaces are removed. procedure Write_Eol_Keep_Blanks; -- Similar as Write_Eol, except that trailing spaces are not removed procedure Write_Int (Val : Int); - -- Write an integer value with no leading blanks or zeroes. Negative - -- values are preceded by a minus sign). + -- Write an integer value with no leading blanks or zeroes. Negative values + -- are preceded by a minus sign). procedure Write_Spaces (N : Nat); -- Write N spaces procedure Write_Str (S : String); -- Write a string of characters to the standard output file. Note that - -- end of line is normally handled separately using WRITE_EOL, but it - -- is allowed for the string to contain LF (but not CR) characters, - -- which are properly interpreted as end of line characters. The string - -- may also contain horizontal tab characters. + -- end of line is normally handled separately using WRITE_EOL, but it is + -- allowable for the string to contain LF (but not CR) characters, which + -- are properly interpreted as end of line characters. The string may also + -- contain horizontal tab characters. procedure Write_Line (S : String); -- Equivalent to Write_Str (S) followed by Write_Eol; function Column return Pos; pragma Inline (Column); - -- Returns the number of the column about to be written (e.g. a value - -- of 1 means the current line is empty). + -- Returns the number of the column about to be written (e.g. a value of 1 + -- means the current line is empty). ------------------------- -- Buffer Save/Restore -- diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index c97710e8ca4..e321affbfb9 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -344,7 +344,8 @@ package body Ch10 is Get_Expected_Unit_Type (File_Name (Current_Source_File)) = Expect_Body then - Error_Msg_BC ("keyword BODY expected here [see file name]"); + Error_Msg_BC -- CODEFIX + ("keyword BODY expected here [see file name]"); Restore_Scan_State (Scan_State); Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod)); else @@ -395,7 +396,8 @@ package body Ch10 is -- Otherwise we saved the semicolon position, so complain else - Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc); + Error_Msg -- CODEFIX + (""";"" should be IS", SIS_Semicolon_Sloc); end if; Body_Node := Unit (Comp_Unit_Node); @@ -836,7 +838,8 @@ package body Ch10 is end if; if Token /= Tok_With then - Error_Msg_SC ("unexpected LIMITED ignored"); + Error_Msg_SC -- CODEFIX + ("unexpected LIMITED ignored"); end if; if Ada_Version < Ada_05 then @@ -876,8 +879,7 @@ package body Ch10 is -- WITH TYPE is an obsolete GNAT specific extension - Error_Msg_SP - ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); + Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead"); Scan; -- past TYPE diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb index 14129bc6230..62887237aa8 100644 --- a/gcc/ada/par-ch11.adb +++ b/gcc/ada/par-ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -119,7 +119,8 @@ package body Ch11 is Set_Choice_Parameter (Handler_Node, Choice_Param_Node); elsif Token = Tok_Others then - Error_Msg_AP ("missing "":"""); + Error_Msg_AP -- CODEFIX + ("missing "":"""); Change_Identifier_To_Defining_Identifier (Choice_Param_Node); Set_Choice_Parameter (Handler_Node, Choice_Param_Node); diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 046ac43e775..642c05a331b 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -346,7 +346,7 @@ package body Ch12 is Scan; -- past OTHERS if Token /= Tok_Arrow then - Error_Msg_BC ("expect arrow after others"); + Error_Msg_BC ("expect arrow after others"); else Scan; -- past arrow end if; @@ -912,7 +912,8 @@ package body Ch12 is Scan; if Token = Tok_Private then - Error_Msg_SC ("TAGGED should be WITH"); + Error_Msg_SC -- CODEFIX + ("TAGGED should be WITH"); Set_Private_Present (Def_Node, True); T_Private; else diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 1b2683379e3..d1bc039b969 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -111,7 +111,6 @@ package body Ch3 is -- current token, and if this is the first such message issued, saves -- the message id in Missing_Begin_Msg, for possible later replacement. - --------------------------------- -- Check_Restricted_Expression -- --------------------------------- @@ -126,9 +125,7 @@ package body Ch3 is and then Paren_Count (N) = 0 then Error_Msg_N - ("|this expression must be parenthesized!", N); - Error_Msg_N - ("\|since extensions (and set notation) are allowed", N); + ("|this expression must be parenthesized in Ada 2012 mode!", N); end if; end Check_Restricted_Expression; @@ -385,7 +382,8 @@ package body Ch3 is Scan; -- past = used in place of IS elsif Token = Tok_Renames then - Error_Msg_SC ("RENAMES should be IS"); + Error_Msg_SC -- CODEFIX + ("RENAMES should be IS"); Scan; -- past RENAMES used in place of IS else @@ -972,7 +970,8 @@ package body Ch3 is TF_Is; if Token = Tok_New then - Error_Msg_SC ("NEW ignored (only allowed in type declaration)"); + Error_Msg_SC -- CODEFIX + ("NEW ignored (only allowed in type declaration)"); Scan; -- past NEW end if; @@ -1358,8 +1357,9 @@ package body Ch3 is procedure No_List is begin if Num_Idents > 1 then - Error_Msg ("identifier list not allowed for RENAMES", - Sloc (Idents (2))); + Error_Msg + ("identifier list not allowed for RENAMES", + Sloc (Idents (2))); end if; List_OK := False; @@ -1379,7 +1379,8 @@ package body Ch3 is Check_Misspelling_Of (Tok_Renames); if Token = Tok_Renames then - Error_Msg_SP ("|extra "":"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "":"" ignored"); Scan; -- past RENAMES return True; else @@ -1750,9 +1751,10 @@ package body Ch3 is -- illegal if Token_Is_Renames then - Error_Msg_N ("constraint not allowed in object renaming " - & "declaration", - Constraint (Object_Definition (Decl_Node))); + Error_Msg_N + ("constraint not allowed in object renaming " + & "declaration", + Constraint (Object_Definition (Decl_Node))); raise Error_Resync; end if; end if; @@ -1981,8 +1983,7 @@ package body Ch3 is T_With; -- past WITH or give error message if Token = Tok_Limited then - Error_Msg_SC - ("LIMITED keyword not allowed in private extension"); + Error_Msg_SC ("LIMITED keyword not allowed in private extension"); Scan; -- ignore LIMITED end if; @@ -2107,7 +2108,6 @@ package body Ch3 is Range_Node : Node_Id; Save_Loc : Source_Ptr; - -- Start of processing for P_Range_Or_Subtype_Mark begin @@ -2170,6 +2170,11 @@ package body Ch3 is return Expr_Node; end if; + -- Simple expression case + + elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then + return Expr_Node; + -- Here we have some kind of error situation. Check for junk parens -- then return what we have, caller will deal with other errors. @@ -3434,8 +3439,7 @@ package body Ch3 is Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); if Token = Tok_Array then - Error_Msg_SC - ("anonymous arrays not allowed as components"); + Error_Msg_SC ("anonymous arrays not allowed as components"); raise Error_Resync; end if; @@ -3514,7 +3518,8 @@ package body Ch3 is Error_Msg ("discriminant name expected", Sloc (Case_Node)); elsif Paren_Count (Case_Node) /= 0 then - Error_Msg ("|discriminant name may not be parenthesized", + Error_Msg + ("|discriminant name may not be parenthesized", Sloc (Case_Node)); Set_Paren_Count (Case_Node, 0); end if; @@ -3657,10 +3662,10 @@ package body Ch3 is -- Expression else - -- If extensions are permitted then the expression must be a - -- simple expression. The resaon for this restriction (i.e. - -- going back to the Ada 83 rule) is to avoid ambiguities - -- when set membership operations are allowed, consider the + -- In Ada 2012 mode, the expression must be a simple + -- expression. The resaon for this restriction (i.e. going + -- back to the Ada 83 rule) is to avoid ambiguities when set + -- membership operations are allowed, consider the -- following: -- when A in 1 .. 10 | 12 => @@ -3673,12 +3678,12 @@ package body Ch3 is -- when (A in 1 .. 10 | 12) => -- when (A in 1 .. 10) | 12 => - -- To solve this, if extensins are enabled, we disallow + -- To solve this, in Ada 2012 mode, we disallow -- the use of membership operations in expressions in -- choices. Technically in the grammar, the expression -- must match the grammar for restricted expression. - if Extensions_Allowed then + if Ada_Version >= Ada_12 then Check_Restricted_Expression (Expr_Node); -- In Ada 83 mode, the syntax required a simple expression @@ -3698,7 +3703,8 @@ package body Ch3 is end if; if Token = Tok_Comma then - Error_Msg_SC (""","" should be ""'|"""); + Error_Msg_SC -- CODEFIX + (""","" should be ""'|"""); else exit when Token /= Tok_Vertical_Bar; end if; @@ -3745,8 +3751,9 @@ package body Ch3 is end if; if Abstract_Present then - Error_Msg_SP ("ABSTRACT not allowed in interface type definition " & - "(RM 3.9.4(2/2))"); + Error_Msg_SP + ("ABSTRACT not allowed in interface type definition " & + "(RM 3.9.4(2/2))"); end if; Scan; -- past INTERFACE @@ -4284,7 +4291,8 @@ package body Ch3 is -- Otherwise we saved the semicolon position, so complain else - Error_Msg ("|"";"" should be IS", SIS_Semicolon_Sloc); + Error_Msg -- CODEFIX + ("|"";"" should be IS", SIS_Semicolon_Sloc); end if; -- The next job is to fix up any declarations that occurred @@ -4519,14 +4527,12 @@ package body Ch3 is Kind = N_Task_Body or else Kind = N_Protected_Body then - Error_Msg - ("proper body not allowed in package spec", Sloc (Decl)); + Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); -- Test for body stub scanned, not acceptable as basic decl item elsif Kind in N_Body_Stub then - Error_Msg - ("body stub not allowed in package spec", Sloc (Decl)); + Error_Msg ("body stub not allowed in package spec", Sloc (Decl)); elsif Kind = N_Assignment_Statement then Error_Msg diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2bb9d25fcc1..d90b413d952 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -63,6 +63,7 @@ package body Ch4 is function P_Aggregate_Or_Paren_Expr return Node_Id; function P_Allocator return Node_Id; + function P_Case_Expression_Alternative return Node_Id; function P_Record_Or_Array_Component_Association return Node_Id; function P_Factor return Node_Id; function P_Primary return Node_Id; @@ -436,7 +437,7 @@ package body Ch4 is elsif Token = Tok_Access then Attr_Name := Name_Access; - elsif Token = Tok_Mod and then Ada_Version = Ada_05 then + elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then Attr_Name := Name_Mod; elsif Apostrophe_Should_Be_Semicolon then @@ -565,8 +566,7 @@ package body Ch4 is elsif Token = Tok_Range then if Expr_Form /= EF_Simple_Name then - Error_Msg_SC -- CODEFIX??? - ("subtype mark must precede RANGE"); + Error_Msg_SC ("subtype mark must precede RANGE"); raise Error_Resync; end if; @@ -1164,6 +1164,13 @@ package body Ch4 is T_Right_Paren; return Expr_Node; + -- Case expression case + + elsif Token = Tok_Case then + Expr_Node := P_Case_Expression; + T_Right_Paren; + return Expr_Node; + -- Note: the mechanism used here of rescanning the initial expression -- is distinctly unpleasant, but it saves a lot of fiddling in scanning -- out the discrete choice list. @@ -1332,7 +1339,7 @@ package body Ch4 is or else Token = Tok_Semicolon then if Present (Assoc_List) then - Error_Msg_BC + Error_Msg_BC -- CODEFIX ("""='>"" expected (positional association cannot follow " & "named association)"); end if; @@ -1570,12 +1577,14 @@ package body Ch4 is end P_Expression; -- This function is identical to the normal P_Expression, except that it - -- also permits the appearence of a conditional expression without the - -- usual surrounding parentheses. + -- also permits the appearence of a case of conditional expression without + -- the usual surrounding parentheses. function P_Expression_If_OK return Node_Id is begin - if Token = Tok_If then + if Token = Tok_Case then + return P_Case_Expression; + elsif Token = Tok_If then return P_Conditional_Expression; else return P_Expression; @@ -1672,11 +1681,13 @@ package body Ch4 is end if; end P_Expression_Or_Range_Attribute; - -- Version that allows a non-parenthesized conditional expression + -- Version that allows a non-parenthesized case or conditional expression function P_Expression_Or_Range_Attribute_If_OK return Node_Id is begin - if Token = Tok_If then + if Token = Tok_Case then + return P_Case_Expression; + elsif Token = Tok_If then return P_Conditional_Expression; else return P_Expression_Or_Range_Attribute; @@ -2339,9 +2350,9 @@ package body Ch4 is return Error; -- If this looks like a conditional expression, then treat it - -- that way with an error messasge. + -- that way with an error message. - elsif Extensions_Allowed then + elsif Ada_Version >= Ada_12 then Error_Msg_SC ("conditional expression must be parenthesized"); return P_Conditional_Expression; @@ -2352,6 +2363,31 @@ package body Ch4 is return P_Identifier; end if; + -- Deal with CASE (possible unparenthesized case expression) + + when Tok_Case => + + -- If this looks like a real case, defined as a CASE appearing + -- the start of a new line, then we consider we have a missing + -- operand. + + if Token_Is_At_Start_Of_Line then + Error_Msg_AP ("missing operand"); + return Error; + + -- If this looks like a case expression, then treat it that way + -- with an error message. + + elsif Ada_Version >= Ada_12 then + Error_Msg_SC ("case expression must be parenthesized"); + return P_Case_Expression; + + -- Otherwise treat as misused identifier + + else + return P_Identifier; + end if; + -- Anything else is illegal as the first token of a primary, but -- we test for a reserved identifier so that it is treated nicely @@ -2360,7 +2396,8 @@ package body Ch4 is return P_Identifier; elsif Prev_Token = Tok_Comma then - Error_Msg_SP ("|extra "","" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); raise Error_Resync; else @@ -2458,7 +2495,8 @@ package body Ch4 is begin if Token = Tok_Box then - Error_Msg_SC ("|""'<'>"" should be ""/="""); + Error_Msg_SC -- CODEFIX + ("|""'<'>"" should be ""/="""); end if; Op_Kind := Relop_Node (Token); @@ -2620,6 +2658,94 @@ package body Ch4 is return Alloc_Node; end P_Allocator; + ----------------------- + -- P_Case_Expression -- + ----------------------- + + function P_Case_Expression return Node_Id is + Loc : constant Source_Ptr := Token_Ptr; + Case_Node : Node_Id; + Save_State : Saved_Scan_State; + + begin + if Ada_Version < Ada_12 then + Error_Msg_SC ("|case expression is an Ada 2012 feature"); + Error_Msg_SC ("\|use -gnat12 switch to compile this unit"); + end if; + + Scan; -- past CASE + Case_Node := + Make_Case_Expression (Loc, + Expression => P_Expression_No_Right_Paren, + Alternatives => New_List); + T_Is; + + -- We now have scanned out CASE expression IS, scan alternatives + + loop + T_When; + Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative); + + -- Missing comma if WHEN (more alternatives present) + + if Token = Tok_When then + T_Comma; + + -- If comma/WHEN, skip comma and we have another alternative + + elsif Token = Tok_Comma then + Save_Scan_State (Save_State); + Scan; -- past comma + + if Token /= Tok_When then + Restore_Scan_State (Save_State); + exit; + end if; + + -- If no comma or WHEN, definitely done + + else + exit; + end if; + end loop; + + -- If we have an END CASE, diagnose as not needed + + if Token = Tok_End then + Error_Msg_SC ("`END CASE` not allowed at end of case expression"); + Scan; -- past END + + if Token = Tok_Case then + Scan; -- past CASE; + end if; + end if; + + -- Return the Case_Expression node + + return Case_Node; + end P_Case_Expression; + + ----------------------------------- + -- P_Case_Expression_Alternative -- + ----------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- EXPRESSION + + -- The caller has checked that and scanned past the initial WHEN token + -- Error recovery: can raise Error_Resync + + function P_Case_Expression_Alternative return Node_Id is + Case_Alt_Node : Node_Id; + begin + Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr); + Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Expression (Case_Alt_Node, P_Expression); + return Case_Alt_Node; + end P_Case_Expression_Alternative; + ------------------------------ -- P_Conditional_Expression -- ------------------------------ @@ -2633,9 +2759,9 @@ package body Ch4 is begin Inside_Conditional_Expression := Inside_Conditional_Expression + 1; - if Token = Tok_If and then not Extensions_Allowed then - Error_Msg_SC ("|conditional expression is an Ada extension"); - Error_Msg_SC ("\|use -gnatX switch to compile this unit"); + if Token = Tok_If and then Ada_Version < Ada_12 then + Error_Msg_SC ("|conditional expression is an Ada 2012 feature"); + Error_Msg_SC ("\|use -gnat12 switch to compile this unit"); end if; Scan; -- past IF or ELSIF @@ -2652,7 +2778,8 @@ package body Ch4 is Scan; -- past semicolon if Token = Tok_Else or else Token = Tok_Elsif then - Error_Msg_SP ("|extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); else Restore_Scan_State (State); @@ -2709,15 +2836,15 @@ package body Ch4 is procedure P_Membership_Test (N : Node_Id) is Alt : constant Node_Id := P_Range_Or_Subtype_Mark - (Allow_Simple_Expression => Extensions_Allowed); + (Allow_Simple_Expression => (Ada_Version >= Ada_12)); begin -- Set case if Token = Tok_Vertical_Bar then - if not Extensions_Allowed then - Error_Msg_SC ("set notation is a language extension"); - Error_Msg_SC ("\|use -gnatX switch to compile this unit"); + if Ada_Version < Ada_12 then + Error_Msg_SC ("set notation is an Ada 2012 feature"); + Error_Msg_SC ("\|use -gnat12 switch to compile this unit"); end if; Set_Alternatives (N, New_List (Alt)); diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index f782f51e024..ec1bcebb8fe 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -193,7 +193,8 @@ package body Ch5 is procedure Test_Statement_Required is begin if Statement_Required then - Error_Msg_BC ("statement expected"); + Error_Msg_BC -- CODEFIX + ("statement expected"); end if; end Test_Statement_Required; @@ -607,7 +608,8 @@ package body Ch5 is or else Nkind (Name_Node) = N_Selected_Component) then - Error_Msg_SC ("""/"" should be ""."""); + Error_Msg_SC -- CODEFIX + ("""/"" should be ""."""); Statement_Required := False; raise Error_Resync; @@ -857,7 +859,8 @@ package body Ch5 is Junk_Declaration; else - Error_Msg_BC ("statement expected"); + Error_Msg_BC -- CODEFIX + ("statement expected"); raise Error_Resync; end if; end case; @@ -1172,7 +1175,8 @@ package body Ch5 is -- of WHEN expression => if Token = Tok_Arrow then - Error_Msg_SC ("THEN expected"); + Error_Msg_SC -- CODEFIX + ("THEN expected"); Scan; -- past the arrow Pop_Scope_Stack; -- remove unneeded entry raise Error_Resync; @@ -1208,7 +1212,8 @@ package body Ch5 is Scan; -- past ELSE if Else_Should_Be_Elsif then - Error_Msg_SP ("ELSE should be ELSIF"); + Error_Msg_SP -- CODEFIX + ("ELSE should be ELSIF"); Add_Elsif_Part; else @@ -1258,7 +1263,8 @@ package body Ch5 is if Token = Tok_Colon_Equal then while Token = Tok_Colon_Equal loop - Error_Msg_SC (""":="" should be ""="""); + Error_Msg_SC -- CODEFIX + (""":="" should be ""="""); Scan; -- past junk := Discard_Junk_Node (P_Expression_No_Right_Paren); end loop; @@ -2196,7 +2202,8 @@ package body Ch5 is -- What we are interested in is whether it was a case of a bad IS. if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then - Error_Msg ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); + Error_Msg -- CODEFIX + ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is); Set_Bad_Is_Detected (Parent, True); end if; @@ -2225,7 +2232,8 @@ package body Ch5 is TF_Then; while Token = Tok_Then loop - Error_Msg_SC ("redundant THEN"); + Error_Msg_SC -- CODEFIX + ("redundant THEN"); TF_Then; end loop; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 2916f53d162..fc9a3741366 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -64,7 +64,8 @@ package body Ch6 is if Token = Tok_Return then Restore_Scan_State (Scan_State); - Error_Msg_SC ("|extra "";"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); Scan; -- rescan past junk semicolon else Restore_Scan_State (Scan_State); @@ -195,7 +196,8 @@ package body Ch6 is Not_Overriding := True; else - Error_Msg_SC ("OVERRIDING expected!"); + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); end if; -- Ada 2005: scan leading OVERRIDING indicator @@ -348,7 +350,8 @@ package body Ch6 is if Token = Tok_Return then if not Func then - Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc); + Error_Msg -- CODEFIX + ("PROCEDURE should be FUNCTION", Fproc_Sloc); Func := True; end if; @@ -421,7 +424,8 @@ package body Ch6 is Scan; -- past semicolon if Token = Tok_Is then - Error_Msg_SP ("extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("extra "";"" ignored"); else Restore_Scan_State (Scan_State); end if; @@ -440,7 +444,8 @@ package body Ch6 is -- semicolon, and go process the body. if Token = Tok_Is then - Error_Msg_SP ("|extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); T_Is; -- scan past IS goto Subprogram_Body; @@ -452,7 +457,8 @@ package body Ch6 is elsif Token = Tok_Begin and then Start_Column >= Scope.Table (Scope.Last).Ecol then - Error_Msg_SP ("|"";"" should be IS!"); + Error_Msg_SP -- CODEFIX + ("|"";"" should be IS!"); goto Subprogram_Body; else @@ -492,7 +498,8 @@ package body Ch6 is -- Deal nicely with (now obsolete) use of <> in place of abstract if Token = Tok_Box then - Error_Msg_SC ("ABSTRACT expected"); + Error_Msg_SC -- CODEFIX + ("ABSTRACT expected"); Token := Tok_Abstract; end if; @@ -556,7 +563,8 @@ package body Ch6 is -- semicolon which should really be an IS else - Error_Msg_AP ("|missing "";"""); + Error_Msg_AP -- CODEFIX + ("|missing "";"""); SIS_Missing_Semicolon_Message := Get_Msg_Id; goto Subprogram_Declaration; end if; @@ -1219,7 +1227,8 @@ package body Ch6 is -- that semicolon should have been a right parenthesis and exit if Token = Tok_Is or else Token = Tok_Return then - Error_Msg_SP ("|"";"" should be "")"""); + Error_Msg_SP -- CODEFIX + ("|"";"" should be "")"""); exit Specification_Loop; end if; @@ -1227,7 +1236,8 @@ package body Ch6 is -- assume we had a missing right parenthesis and terminate list if Token in Token_Class_Declk then - Error_Msg_AP ("missing "")"""); + Error_Msg_AP -- CODEFIX + ("missing "")"""); Restore_Scan_State (Scan_State); exit Specification_Loop; end if; @@ -1290,7 +1300,8 @@ package body Ch6 is Set_In_Present (Node, True); if Style.Mode_In_Check and then Token /= Tok_Out then - Error_Msg_SP ("(style) IN should be omitted"); + Error_Msg_SP -- CODEFIX + ("(style) IN should be omitted"); end if; if Token = Tok_Access then @@ -1305,8 +1316,7 @@ package body Ch6 is end if; if Token = Tok_In then - Error_Msg_SC -- CODEFIX ??? - ("IN must precede OUT in parameter mode"); + Error_Msg_SC ("IN must precede OUT in parameter mode"); Scan; -- past IN Set_In_Present (Node, True); end if; diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index 3b24c8792b8..d4d168de7bc 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -69,10 +69,10 @@ package body Ch7 is -- Pf_Flags.Rnam Set if renaming declaration OK -- Pf_Flags.Stub Set if body stub OK - -- If an inappropriate form is encountered, it is scanned out but an - -- error message indicating that it is appearing in an inappropriate - -- context is issued. The only possible settings for Pf_Flags are those - -- defined as constants in package Par. + -- If an inappropriate form is encountered, it is scanned out but an error + -- message indicating that it is appearing in an inappropriate context is + -- issued. The only possible settings for Pf_Flags are those defined as + -- constants in package Par. -- Note: in all contexts where a package specification is required, there -- is a terminating semicolon. This semicolon is scanned out in the case @@ -101,7 +101,8 @@ package body Ch7 is Scan; -- past PACKAGE if Token = Tok_Type then - Error_Msg_SC ("TYPE not allowed here"); + Error_Msg_SC -- CODEFIX + ("TYPE not allowed here"); Scan; -- past TYPE end if; diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 1271d478a73..23b27c7774e 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -154,7 +154,8 @@ package body Ch9 is Scan; -- past semicolon if Token = Tok_Entry then - Error_Msg_SP ("|"";"" should be IS"); + Error_Msg_SP -- CODEFIX + ("|"";"" should be IS"); Set_Task_Definition (Task_Node, P_Task_Definition); else Pop_Scope_Stack; -- Remove unused entry @@ -181,13 +182,14 @@ package body Ch9 is end loop; if Token /= Tok_With then - Error_Msg_SC ("WITH expected"); + Error_Msg_SC -- CODEFIX + ("WITH expected"); end if; Scan; -- past WITH if Token = Tok_Private then - Error_Msg_SP + Error_Msg_SP -- CODEFIX ("PRIVATE not allowed in task type declaration"); end if; end if; @@ -454,7 +456,8 @@ package body Ch9 is if Token /= Tok_Is then Restore_Scan_State (Scan_State); - Error_Msg_SC ("missing IS"); + Error_Msg_SC -- CODEFIX + ("missing IS"); Set_Protected_Definition (Protected_Node, Make_Protected_Definition (Token_Ptr, Visible_Declarations => Empty_List, @@ -466,7 +469,8 @@ package body Ch9 is return Protected_Node; end if; - Error_Msg_SP ("|extra ""("" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra ""("" ignored"); end if; T_Is; @@ -492,7 +496,8 @@ package body Ch9 is end loop; if Token /= Tok_With then - Error_Msg_SC ("WITH expected"); + Error_Msg_SC -- CODEFIX + ("WITH expected"); end if; Scan; -- past WITH @@ -625,7 +630,8 @@ package body Ch9 is Scan; -- past OVERRIDING Not_Overriding := True; else - Error_Msg_SC ("OVERRIDING expected!"); + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); end if; else @@ -758,8 +764,7 @@ package body Ch9 is Scan; -- past PRIVATE elsif Token = Tok_Identifier then - Error_Msg_SC - ("all components must be declared in spec!"); + Error_Msg_SC ("all components must be declared in spec!"); Resync_Past_Semicolon; elsif Token in Token_Class_Declk then @@ -809,7 +814,8 @@ package body Ch9 is Scan; -- part OVERRIDING Not_Overriding := True; else - Error_Msg_SC ("OVERRIDING expected!"); + Error_Msg_SC -- CODEFIX + ("OVERRIDING expected!"); end if; elsif Token = Tok_Overriding then @@ -823,7 +829,8 @@ package body Ch9 is Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); elsif Token /= Tok_Entry then - Error_Msg_SC ("ENTRY expected!"); + Error_Msg_SC -- CODEFIX + ("ENTRY expected!"); end if; end if; @@ -1115,7 +1122,8 @@ package body Ch9 is Bnode := P_Expression_No_Right_Paren; if Token = Tok_Colon_Equal then - Error_Msg_SC ("|"":="" should be ""="""); + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""="""); Scan; Bnode := P_Expression_No_Right_Paren; end if; diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 94e753976aa..5b16bce00b9 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb index 9874c4fcef9..6609a07576e 100644 --- a/gcc/ada/par-labl.adb +++ b/gcc/ada/par-labl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -375,13 +375,21 @@ procedure Labl is and then Matches (Node (N), Node (S1)) then if not Found then - if Parent (Node (N)) = Parent (Node (S1)) then + + -- If the label and the goto are both in the same statement + -- list, then we've found a loop. Note that labels and goto + -- statements are always part of some list, so + -- List_Containing always makes sense. + + if List_Containing (Node (N)) = + List_Containing (Node (S1)) + then Source := S1; Found := True; - else - -- The goto is within some nested structure + -- The goto is within some nested structure + else No_Header (N); return; end if; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 9b5b0ab76a3..a421592ad84 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -150,8 +150,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Error_Msg_Name_2 := Name_On; Error_Msg_Name_3 := Name_Off; - Error_Msg - ("argument for pragma% must be% or%", Sloc (Argx)); + Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); raise Error_Resync; end if; end Check_Arg_Is_On_Or_Off; @@ -307,7 +306,7 @@ begin -- Ada_05/Ada_2005 -- --------------------- - -- This pragma must be processed at parse time, since we want to set + -- These pragmas must be processed at parse time, since we want to set -- the Ada version properly at parse time to recognize the appropriate -- Ada version syntax. However, it is only the zero argument form that -- must be processed at parse time. @@ -318,6 +317,18 @@ begin Ada_Version_Explicit := Ada_05; end if; + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- + + -- These pragmas must be processed at parse time, since we want to set + -- the Ada version properly at parse time to recognize the appropriate + -- Ada version syntax. + + when Pragma_Ada_12 | Pragma_Ada_2012 => + Ada_Version := Ada_12; + Ada_Version_Explicit := Ada_12; + ----------- -- Debug -- ----------- @@ -375,8 +386,10 @@ begin if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; + Ada_Version := Ada_12; else Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; end if; ---------------- @@ -943,7 +956,11 @@ begin OK := False; elsif Chars (A) = Name_All_Checks then - Stylesw.Set_Default_Style_Check_Options; + if GNAT_Mode then + Stylesw.Set_GNAT_Style_Check_Options; + else + Stylesw.Set_Default_Style_Check_Options; + end if; elsif Chars (A) = Name_On then Style_Check := True; diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index 9329b41cd14..c92b20fbfe2 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -83,15 +83,18 @@ package body Tchk is -- A little recovery helper, accept then in place of => elsif Token = Tok_Then then - Error_Msg_BC ("|THEN should be ""='>"""); + Error_Msg_BC -- CODEFIX + ("|THEN should be ""='>"""); Scan; -- past THEN used in place of => elsif Token = Tok_Colon_Equal then - Error_Msg_SC ("|"":="" should be ""='>"""); + Error_Msg_SC -- CODEFIX + ("|"":="" should be ""='>"""); Scan; -- past := used in place of => else - Error_Msg_AP ("missing ""='>"""); + Error_Msg_AP -- CODEFIX + ("missing ""='>"""); end if; end T_Arrow; @@ -122,7 +125,8 @@ package body Tchk is if Token = Tok_Box then Scan; else - Error_Msg_AP ("missing ""'<'>"""); + Error_Msg_AP -- CODEFIX + ("missing ""'<'>"""); end if; end T_Box; @@ -135,7 +139,8 @@ package body Tchk is if Token = Tok_Colon then Scan; else - Error_Msg_AP ("missing "":"""); + Error_Msg_AP -- CODEFIX + ("missing "":"""); end if; end T_Colon; @@ -149,19 +154,23 @@ package body Tchk is Scan; elsif Token = Tok_Equal then - Error_Msg_SC ("|""="" should be "":="""); + Error_Msg_SC -- CODEFIX + ("|""="" should be "":="""); Scan; elsif Token = Tok_Colon then - Error_Msg_SC ("|"":"" should be "":="""); + Error_Msg_SC -- CODEFIX + ("|"":"" should be "":="""); Scan; elsif Token = Tok_Is then - Error_Msg_SC ("|IS should be "":="""); + Error_Msg_SC -- CODEFIX + ("|IS should be "":="""); Scan; else - Error_Msg_AP ("missing "":="""); + Error_Msg_AP -- CODEFIX + ("missing "":="""); end if; end T_Colon_Equal; @@ -182,7 +191,8 @@ package body Tchk is if Token = Tok_Comma then Scan; else - Error_Msg_AP ("missing "","""); + Error_Msg_AP -- CODEFIX + ("missing "","""); end if; end if; @@ -200,7 +210,8 @@ package body Tchk is if Token = Tok_Dot_Dot then Scan; else - Error_Msg_AP ("missing "".."""); + Error_Msg_AP -- CODEFIX + ("missing "".."""); end if; end T_Dot_Dot; @@ -222,7 +233,8 @@ package body Tchk is if Token = Tok_Greater_Greater then Scan; else - Error_Msg_AP ("missing ""'>'>"""); + Error_Msg_AP -- CODEFIX + ("missing ""'>'>"""); end if; end T_Greater_Greater; @@ -271,15 +283,18 @@ package body Tchk is -- Allow OF, => or = to substitute for IS with complaint elsif Token = Tok_Arrow then - Error_Msg_SC ("|""=>"" should be IS"); + Error_Msg_SC -- CODEFIX + ("|""=>"" should be IS"); Scan; -- past => elsif Token = Tok_Of then - Error_Msg_SC ("|OF should be IS"); + Error_Msg_SC -- CODEFIX + ("|OF should be IS"); Scan; -- past OF elsif Token = Tok_Equal then - Error_Msg_SC ("|""="" should be IS"); + Error_Msg_SC -- CODEFIX + ("|""="" should be IS"); Scan; -- past = else @@ -289,7 +304,8 @@ package body Tchk is -- Ignore extra IS keywords while Token = Tok_Is loop - Error_Msg_SC ("|extra IS ignored"); + Error_Msg_SC -- CODEFIX + ("|extra IS ignored"); Scan; end loop; end T_Is; @@ -303,7 +319,8 @@ package body Tchk is if Token = Tok_Left_Paren then Scan; else - Error_Msg_AP ("missing ""("""); + Error_Msg_AP -- CODEFIX + ("missing ""("""); end if; end T_Left_Paren; @@ -314,7 +331,8 @@ package body Tchk is procedure T_Loop is begin if Token = Tok_Do then - Error_Msg_SC ("LOOP expected"); + Error_Msg_SC -- CODEFIX + ("LOOP expected"); Scan; else Check_Token (Tok_Loop, AP); @@ -393,7 +411,8 @@ package body Tchk is if Token = Tok_Right_Paren then Scan; else - Error_Msg_AP ("|missing "")"""); + Error_Msg_AP -- CODEFIX + ("|missing "")"""); end if; end T_Right_Paren; @@ -408,24 +427,28 @@ package body Tchk is Scan; if Token = Tok_Semicolon then - Error_Msg_SC ("|extra "";"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); Scan; end if; return; elsif Token = Tok_Colon then - Error_Msg_SC ("|"":"" should be "";"""); + Error_Msg_SC -- CODEFIX + ("|"":"" should be "";"""); Scan; return; elsif Token = Tok_Comma then - Error_Msg_SC ("|"","" should be "";"""); + Error_Msg_SC -- CODEFIX + ("|"","" should be "";"""); Scan; return; elsif Token = Tok_Dot then - Error_Msg_SC ("|""."" should be "";"""); + Error_Msg_SC -- CODEFIX + ("|""."" should be "";"""); Scan; return; @@ -464,7 +487,8 @@ package body Tchk is -- If none of those tests return, we really have a missing semicolon - Error_Msg_AP ("|missing "";"""); + Error_Msg_AP -- CODEFIX + ("|missing "";"""); return; end T_Semicolon; @@ -646,7 +670,8 @@ package body Tchk is Scan; -- skip RETURN and we are done else - Error_Msg_SC ("missing RETURN"); + Error_Msg_SC -- CODEFIX + ("missing RETURN"); Save_Scan_State (Scan_State); -- at start of junk tokens loop @@ -814,7 +839,8 @@ package body Tchk is if Token = Tok_Left_Paren then Scan; else - Error_Msg_AP ("missing ""(""!"); + Error_Msg_AP -- CODEFIX + ("missing ""(""!"); end if; end U_Left_Paren; @@ -827,7 +853,8 @@ package body Tchk is if Token = Tok_Right_Paren then Scan; else - Error_Msg_AP ("|missing "")""!"); + Error_Msg_AP -- CODEFIX + ("|missing "")""!"); end if; end U_Right_Paren; @@ -846,7 +873,8 @@ package body Tchk is Scan; if Token = T then - Error_Msg_SP ("|extra "";"" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "";"" ignored"); Scan; else Error_Msg_SP (M); @@ -856,7 +884,8 @@ package body Tchk is Scan; if Token = T then - Error_Msg_SP ("|extra "","" ignored"); + Error_Msg_SP -- CODEFIX + ("|extra "","" ignored"); Scan; else diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 3672ca8145e..6a0e8efc6cb 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -72,7 +72,8 @@ package body Util is and then Name_Len = 7 and then Name_Buffer (1 .. 7) = "program" then - Error_Msg_SC ("PROCEDURE expected"); + Error_Msg_SC -- CODEFIX + ("PROCEDURE expected"); Token := T; return True; @@ -86,8 +87,7 @@ package body Util is M2 (P2 + J - 1) := Fold_Upper (S (J)); end loop; - Error_Msg_SC -- CODEFIX??? - (M2 (1 .. P2 - 1 + S'Last)); + Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last)); Token := T; return True; end if; @@ -334,7 +334,8 @@ package body Util is <<Assume_Comma>> Restore_Scan_State (Scan_State); - Error_Msg_SC ("|"";"" should be "","""); + Error_Msg_SC -- CODEFIX + ("|"";"" should be "","""); Scan; -- past the semicolon return True; @@ -384,26 +385,30 @@ package body Util is begin while Token = T loop if T = Tok_Comma then - Error_Msg_SC ("|extra "","" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "","" ignored"); elsif T = Tok_Left_Paren then - Error_Msg_SC ("|extra ""("" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra ""("" ignored"); elsif T = Tok_Right_Paren then - Error_Msg_SC ("|extra "")"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "")"" ignored"); elsif T = Tok_Semicolon then - Error_Msg_SC ("|extra "";"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "";"" ignored"); elsif T = Tok_Colon then - Error_Msg_SC ("|extra "":"" ignored"); + Error_Msg_SC -- CODEFIX + ("|extra "":"" ignored"); else declare Tname : constant String := Token_Type'Image (Token); begin - Error_Msg_SC - ("|extra " & Tname (5 .. Tname'Last) & "ignored"); + Error_Msg_SC ("|extra " & Tname (5 .. Tname'Last) & "ignored"); end; end if; @@ -567,8 +572,7 @@ package body Util is end; Error_Msg_Node_1 := Prev; - Error_Msg_SC - ("unexpected identifier, possibly & was meant here"); + Error_Msg_SC ("unexpected identifier, possibly & was meant here"); Scan; end Merge_Identifier; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 78ffd604ebd..bf3dc1e6b51 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -676,8 +676,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Simple_Expression return Node_Id; function P_Simple_Expression_Or_Range_Attribute return Node_Id; + function P_Case_Expression return Node_Id; + -- Scans out a case expression. Called with Token pointing to the CASE + -- keyword, and returns pointing to the terminating right parent, + -- semicolon, or comma, but does not consume this terminating token. + function P_Conditional_Expression return Node_Id; - -- Scans out a conditional expression. Called with token pointing to + -- Scans out a conditional expression. Called with Token pointing to -- the IF keyword, and returns pointing to the terminating right paren, -- semicolon or comma, but does not consume this terminating token. @@ -1182,12 +1187,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -------------- procedure Labl; - -- This procedure creates implicit label declarations for all label that - -- are declared in the current unit. Note that this could conceptually - -- be done at the point where the labels are declared, but it is tricky - -- to do it then, since the tree is not hooked up at the point where the - -- label is declared (e.g. a sequence of statements is not yet attached - -- to its containing scope at the point a label in the sequence is found) + -- This procedure creates implicit label declarations for all labels that + -- are declared in the current unit. Note that this could conceptually be + -- done at the point where the labels are declared, but it is tricky to do + -- it then, since the tree is not hooked up at the point where the label is + -- declared (e.g. a sequence of statements is not yet attached to its + -- containing scope at the point a label in the sequence is found). -------------- -- Par.Load -- diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 82ab9d651a0..7dbaf93af89 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, 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- -- @@ -63,13 +63,14 @@ package body Par_SCO is Table_Increment => 200, Table_Name => "SCO_Unit_Number_Entry"); - -------------------------- - -- Condition Hash Table -- - -------------------------- + --------------------------------- + -- Condition/Pragma Hash Table -- + --------------------------------- -- We need to be able to get to conditions quickly for handling the calls - -- to Set_SCO_Condition efficiently. For this purpose we identify the - -- conditions in the table by their starting sloc, and use the following + -- to Set_SCO_Condition efficiently, and similarly to get to pragmas to + -- handle calls to Set_SCO_Pragma_Enabled. For this purpose we identify the + -- conditions and pragmas in the table by their starting sloc, and use this -- hash table to map from these starting sloc values to SCO_Table indexes. type Header_Num is new Integer range 0 .. 996; @@ -81,7 +82,7 @@ package body Par_SCO is function Equal (F1, F2 : Source_Ptr) return Boolean; -- Function to test two keys for equality - package Condition_Hash_Table is new Simple_HTable + package Condition_Pragma_Hash_Table is new Simple_HTable (Header_Num, Int, 0, Source_Ptr, Hash, Equal); -- The actual hash table @@ -104,8 +105,9 @@ package body Par_SCO is -- If N is Empty, has no effect. Otherwise scans the tree for the node N, -- to output any decisions it contains. T is one of IEPWX (for context of -- expresion: if/exit when/pragma/while/expression). If T is other than X, - -- then a decision is always present (at the very least a simple decision - -- is present at the top level). + -- the node N is the conditional expression involved, and a decision is + -- always present (at the very least a simple decision is present at the + -- top level). procedure Process_Decisions (L : List_Id; T : Character); -- Calls above procedure for each element of the list L @@ -119,11 +121,13 @@ package body Par_SCO is -- Append an entry to SCO_Table with fields set as per arguments procedure Traverse_Declarations_Or_Statements (L : List_Id); + procedure Traverse_Generic_Instantiation (N : Node_Id); procedure Traverse_Generic_Package_Declaration (N : Node_Id); procedure Traverse_Handled_Statement_Sequence (N : Node_Id); procedure Traverse_Package_Body (N : Node_Id); procedure Traverse_Package_Declaration (N : Node_Id); procedure Traverse_Subprogram_Body (N : Node_Id); + procedure Traverse_Subprogram_Declaration (N : Node_Id); -- Traverse the corresponding construct, generating SCO table entries procedure Write_SCOs_To_ALI_File is new Put_SCOs; @@ -299,8 +303,7 @@ package body Par_SCO is function Is_Logical_Operator (N : Node_Id) return Boolean is begin - return Nkind_In (N, N_Op_Xor, - N_Op_Not, + return Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else); end Is_Logical_Operator; @@ -327,6 +330,17 @@ package body Par_SCO is procedure Process_Decisions (N : Node_Id; T : Character) is + Mark : Nat; + -- This is used to mark the location of a decision sequence in the SCO + -- table. We use it for backing out a simple decision in an expression + -- context that contains only NOT operators. + + X_Not_Decision : Boolean; + -- This flag keeps track of whether a decision sequence in the SCO table + -- contains only NOT operators, and is for an expression context (T=X). + -- The flag will be set False if T is other than X, or if an operator + -- other than NOT is in the sequence. + function Process_Node (N : Node_Id) return Traverse_Result; -- Processes one node in the traversal, looking for logical operators, -- and if one is found, outputs the appropriate table entries. @@ -340,13 +354,15 @@ package body Par_SCO is -- Process_Decision_Operand, because we can't get decisions mixed up in -- the global table. Call has no effect if N is Empty. - procedure Output_Element (N : Node_Id; T : Character); + procedure Output_Element (N : Node_Id); -- Node N is an operand of a logical operator that is not itself a -- logical operator, or it is a simple decision. This routine outputs - -- the table entry for the element, with C1 set to T (' ' for one of - -- the elements of a complex decision, or 'I'/'W'/'E' for a simple - -- decision (from an IF, WHILE, or EXIT WHEN). Last is set to False, - -- and an entry is made in the condition hash table. + -- the table entry for the element, with C1 set to ' '. Last is set + -- False, and an entry is made in the condition hash table. + + procedure Output_Header (T : Character); + -- Outputs a decision header node. T is I/W/E/P for IF/WHILE/EXIT WHEN/ + -- PRAGMA, and 'X' for the expression case. procedure Process_Decision_Operand (N : Node_Id); -- This is called on node N, the top level node of a decision, or on one @@ -376,16 +392,19 @@ package body Par_SCO is else L := Left_Opnd (N); - if Nkind (N) = N_Op_Xor then - C := '^'; - elsif Nkind_In (N, N_Op_Or, N_Or_Else) then + if Nkind_In (N, N_Op_Or, N_Or_Else) then C := '|'; else C := '&'; end if; end if; - Set_Table_Entry (C, ' ', No_Location, No_Location, False); + Set_Table_Entry + (C1 => C, + C2 => ' ', + From => Sloc (N), + To => No_Location, + Last => False); Output_Decision_Operand (L); Output_Decision_Operand (Right_Opnd (N)); @@ -393,7 +412,7 @@ package body Par_SCO is -- Not a logical operator else - Output_Element (N, ' '); + Output_Element (N); end if; end Output_Decision_Operand; @@ -401,15 +420,83 @@ package body Par_SCO is -- Output_Element -- -------------------- - procedure Output_Element (N : Node_Id; T : Character) is + procedure Output_Element (N : Node_Id) is FSloc : Source_Ptr; LSloc : Source_Ptr; begin Sloc_Range (N, FSloc, LSloc); - Set_Table_Entry (T, 'c', FSloc, LSloc, False); - Condition_Hash_Table.Set (FSloc, SCO_Table.Last); + Set_Table_Entry + (C1 => ' ', + C2 => 'c', + From => FSloc, + To => LSloc, + Last => False); + Condition_Pragma_Hash_Table.Set (FSloc, SCO_Table.Last); end Output_Element; + ------------------- + -- Output_Header -- + ------------------- + + procedure Output_Header (T : Character) is + begin + case T is + when 'I' | 'E' | 'W' => + + -- For IF, EXIT, WHILE, the token SLOC can be found from + -- the SLOC of the parent of the expression. + + Set_Table_Entry + (C1 => T, + C2 => ' ', + From => Sloc (Parent (N)), + To => No_Location, + Last => False); + + when 'P' => + + -- For PRAGMA, we must get the location from the pragma node. + -- Argument N is the pragma argument, and we have to go up two + -- levels (through the pragma argument association) to get to + -- the pragma node itself. + + declare + Loc : constant Source_Ptr := Sloc (Parent (Parent (N))); + + begin + Set_Table_Entry + (C1 => 'P', + C2 => 'd', + From => Loc, + To => No_Location, + Last => False); + + -- For pragmas we also must make an entry in the hash table + -- for later access by Set_SCO_Pragma_Enabled. We set the + -- pragma as disabled above, the call will change C2 to 'e' + -- to enable the pragma header entry. + + Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last); + end; + + when 'X' => + + -- For an expression, no Sloc + + Set_Table_Entry + (C1 => 'X', + C2 => ' ', + From => No_Location, + To => No_Location, + Last => False); + + -- No other possibilities + + when others => + raise Program_Error; + end case; + end Output_Header; + ------------------------------ -- Process_Decision_Operand -- ------------------------------ @@ -419,6 +506,7 @@ package body Par_SCO is if Is_Logical_Operator (N) then if Nkind (N) /= N_Op_Not then Process_Decision_Operand (Left_Opnd (N)); + X_Not_Decision := False; end if; Process_Decision_Operand (Right_Opnd (N)); @@ -439,9 +527,9 @@ package body Par_SCO is -- Logical operators, output table entries and then process -- operands recursively to deal with nested conditions. - when N_And_Then | - N_Or_Else | - N_Op_Not => + when N_And_Then | + N_Or_Else | + N_Op_Not => declare T : Character; @@ -458,15 +546,26 @@ package body Par_SCO is -- Output header for sequence - Set_Table_Entry (T, ' ', No_Location, No_Location, False); + X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not; + Mark := SCO_Table.Last; + Output_Header (T); -- Output the decision Output_Decision_Operand (N); - -- Change Last in last table entry to True to mark end + -- If the decision was in an expression context (T = 'X') + -- and contained only NOT operators, then we don't output + -- it, so delete it. + + if X_Not_Decision then + SCO_Table.Set_Last (Mark); - SCO_Table.Table (SCO_Table.Last).Last := True; + -- Otherwise, set Last in last table entry to mark end + + else + SCO_Table.Table (SCO_Table.Last).Last := True; + end if; -- Process any embedded decisions @@ -474,9 +573,14 @@ package body Par_SCO is return Skip; end; + -- Case expression + + when N_Case_Expression => + return OK; -- ??? + -- Conditional expression, processed like an if statement - when N_Conditional_Expression => + when N_Conditional_Expression => declare Cond : constant Node_Id := First (Expressions (N)); Thnx : constant Node_Id := Next (Cond); @@ -508,11 +612,12 @@ package body Par_SCO is -- See if we have simple decision at outer level and if so then -- generate the decision entry for this simple decision. A simple -- decision is a boolean expression (which is not a logical operator - -- or short circuit form) appearing as the operand of an IF, WHILE - -- or EXIT WHEN construct. + -- or short circuit form) appearing as the operand of an IF, WHILE, + -- EXIT WHEN, or special PRAGMA construct. if T /= 'X' and then not Is_Logical_Operator (N) then - Output_Element (N, T); + Output_Header (T); + Output_Element (N); -- Change Last in last table entry to True to mark end of -- sequence, which is this case is only one element long. @@ -671,6 +776,9 @@ package body Par_SCO is if Nkind (Lu) = N_Subprogram_Body then Traverse_Subprogram_Body (Lu); + elsif Nkind (Lu) = N_Subprogram_Declaration then + Traverse_Subprogram_Declaration (Lu); + elsif Nkind (Lu) = N_Package_Declaration then Traverse_Package_Declaration (Lu); @@ -680,12 +788,14 @@ package body Par_SCO is elsif Nkind (Lu) = N_Generic_Package_Declaration then Traverse_Generic_Package_Declaration (Lu); - -- For anything else, the only issue is default expressions for - -- parameters, where we have to worry about possible embedded decisions - -- but nothing else. + elsif Nkind (Lu) in N_Generic_Instantiation then + Traverse_Generic_Instantiation (Lu); + + -- All other cases of compilation units (e.g. renamings), generate + -- no SCO information. else - Process_Decisions (Lu, 'X'); + null; end if; -- Make entry for new unit in unit tables, we will fill in the file @@ -704,14 +814,48 @@ package body Par_SCO is -- Set_SCO_Condition -- ----------------------- - procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character) is - Index : constant Nat := Condition_Hash_Table.Get (First_Loc); + procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean) is + Orig : constant Node_Id := Original_Node (Cond); + Index : Nat; + Start : Source_Ptr; + Dummy : Source_Ptr; + + Constant_Condition_Code : constant array (Boolean) of Character := + (False => 'f', True => 't'); begin + Sloc_Range (Orig, Start, Dummy); + Index := Condition_Pragma_Hash_Table.Get (Start); + + -- The test here for zero is to deal with possible previous errors + if Index /= 0 then - SCO_Table.Table (Index).C2 := Typ; + pragma Assert (SCO_Table.Table (Index).C1 = ' '); + SCO_Table.Table (Index).C2 := Constant_Condition_Code (Val); end if; end Set_SCO_Condition; + ---------------------------- + -- Set_SCO_Pragma_Enabled -- + ---------------------------- + + procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr) is + Index : Nat; + + begin + -- Note: the reason we use the Sloc value as the key is that in the + -- generic case, the call to this procedure is made on a copy of the + -- original node, so we can't use the Node_Id value. + + Index := Condition_Pragma_Hash_Table.Get (Loc); + + -- The test here for zero is to deal with possible previous errors + + if Index /= 0 then + pragma Assert (SCO_Table.Table (Index).C1 = 'P'); + SCO_Table.Table (Index).C2 := 'e'; + end if; + end Set_SCO_Pragma_Enabled; + --------------------- -- Set_Table_Entry -- --------------------- @@ -756,34 +900,73 @@ package body Par_SCO is -- Traverse_Declarations_Or_Statements -- ----------------------------------------- + -- Tables used by Traverse_Declarations_Or_Statements for temporarily + -- holding statement and decision entries. These are declared globally + -- since they are shared by recursive calls to this procedure. + + type SC_Entry is record + From : Source_Ptr; + To : Source_Ptr; + Typ : Character; + end record; + -- Used to store a single entry in the following table, From:To represents + -- the range of entries in the CS line entry, and typ is the type, with + -- space meaning that no type letter will accompany the entry. + + package SC is new Table.Table ( + Table_Component_Type => SC_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SC"); + -- Used to store statement components for a CS entry to be output + -- as a result of the call to this procedure. SC.Last is the last + -- entry stored, so the current statement sequence is represented + -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on + -- entry to each recursive call to the routine. + -- + -- Extend_Statement_Sequence adds an entry to this array, and then + -- Set_Statement_Entry clears the entries starting with SC_First, + -- copying these entries to the main SCO output table. The reason that + -- we do the temporary caching of results in this array is that we want + -- the SCO table entries for a given CS line to be contiguous, and the + -- processing may output intermediate entries such as decision entries. + + type SD_Entry is record + Nod : Node_Id; + Lst : List_Id; + Typ : Character; + end record; + -- Used to store a single entry in the following table. Nod is the node to + -- be searched for decisions for the case of Process_Decisions_Defer with a + -- node argument (with Lst set to No_List. Lst is the list to be searched + -- for decisions for the case of Process_Decisions_Defer with a List + -- argument (in which case Nod is set to Empty). + + package SD is new Table.Table ( + Table_Component_Type => SD_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "SCO_SD"); + -- Used to store possible decision information. Instead of calling the + -- Process_Decisions procedures directly, we call Process_Decisions_Defer, + -- which simply stores the arguments in this table. Then when we clear + -- out a statement sequence using Set_Statement_Entry, after generating + -- the CS lines for the statements, the entries in this table result in + -- calls to Process_Decision. The reason for doing things this way is to + -- ensure that decisions are output after the CS line for the statements + -- in which the decisions occur. + procedure Traverse_Declarations_Or_Statements (L : List_Id) is N : Node_Id; Dummy : Source_Ptr; - type SC_Entry is record - From : Source_Ptr; - To : Source_Ptr; - Typ : Character; - end record; - -- Used to store a single entry in the following array - - SC_Array : array (Nat range 1 .. 10_000) of SC_Entry; - SC_Last : Nat; - -- Used to store statement components for a CS entry to be output - -- as a result of the call to this procedure. SC_Last is the last - -- entry stored, so the current statement sequence is represented - -- by SC_Array (1 .. SC_Last). Extend_Statement_Sequence adds an - -- entry to this array, and Set_Statement_Entry clears it, copying - -- the entries to the main SCO output table. The reason that we do - -- the temporary caching of results in this array is that we want - -- the SCO table entries for a given CS line to be contiguous, and - -- the processing may output intermediate entries such as decision - -- entries. Note that the limit of 10_000 here is arbitrary, but does - -- not cause any trouble, if we encounter more than 10_000 statements - -- we simply break the current CS sequence at that point, which is - -- harmless, since this is only used for back annotation and it is - -- not critical that back annotation always work in all cases. Anyway - -- exceeding 10,000 statements in a basic block is very unlikely. + SC_First : constant Nat := SC.Last + 1; + SD_First : constant Nat := SD.Last + 1; + -- Record first entries used in SC/SD at this recursive level procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character); -- Extend the current statement sequence to encompass the node N. Typ @@ -806,32 +989,69 @@ package body Par_SCO is -- called when we find a statement or declaration that generates its -- own table entry, so that we must end the current statement sequence. + procedure Process_Decisions_Defer (N : Node_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- This routine is logically the same as Process_Decisions, except that + -- the arguments are saved in the SD table, for later processing when + -- Set_Statement_Entry is called, which goes through the saved entries + -- making the corresponding calls to Process_Decision. + + procedure Process_Decisions_Defer (L : List_Id; T : Character); + pragma Inline (Process_Decisions_Defer); + -- Same case for list arguments, deferred call to Process_Decisions + ------------------------- -- Set_Statement_Entry -- ------------------------- procedure Set_Statement_Entry is - C1 : Character; + C1 : Character; + SC_Last : constant Int := SC.Last; + SD_Last : constant Int := SD.Last; begin - if SC_Last /= 0 then - for J in 1 .. SC_Last loop - if J = 1 then - C1 := 'S'; - else - C1 := 's'; - end if; + -- Output statement entries from saved entries in SC table + for J in SC_First .. SC_Last loop + if J = SC_First then + C1 := 'S'; + else + C1 := 's'; + end if; + + declare + SCE : SC_Entry renames SC.Table (J); + begin Set_Table_Entry (C1 => C1, - C2 => SC_Array (J).Typ, - From => SC_Array (J).From, - To => SC_Array (J).To, + C2 => SCE.Typ, + From => SCE.From, + To => SCE.To, Last => (J = SC_Last)); - end loop; + end; + end loop; - SC_Last := 0; - end if; + -- Clear out used section of SC table + + SC.Set_Last (SC_First - 1); + + -- Output any embedded decisions + + for J in SD_First .. SD_Last loop + declare + SDE : SD_Entry renames SD.Table (J); + begin + if Present (SDE.Nod) then + Process_Decisions (SDE.Nod, SDE.Typ); + else + Process_Decisions (SDE.Lst, SDE.Typ); + end if; + end; + end loop; + + -- Clear out used section of SD table + + SD.Set_Last (SD_First - 1); end Set_Statement_Entry; ------------------------------- @@ -839,20 +1059,11 @@ package body Par_SCO is ------------------------------- procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is + F : Source_Ptr; + T : Source_Ptr; begin - -- Clear out statement sequence if array full - - if SC_Last = SC_Array'Last then - Set_Statement_Entry; - else - SC_Last := SC_Last + 1; - end if; - - -- Record new entry - - Sloc_Range - (N, SC_Array (SC_Last).From, SC_Array (SC_Last).To); - SC_Array (SC_Last).Typ := Typ; + Sloc_Range (N, F, T); + SC.Append ((F, T, Typ)); end Extend_Statement_Sequence; procedure Extend_Statement_Sequence @@ -860,27 +1071,32 @@ package body Par_SCO is To : Node_Id; Typ : Character) is + F : Source_Ptr; + T : Source_Ptr; begin - -- Clear out statement sequence if array full + Sloc_Range (From, F, Dummy); + Sloc_Range (To, Dummy, T); + SC.Append ((F, T, Typ)); + end Extend_Statement_Sequence; - if SC_Last = SC_Array'Last then - Set_Statement_Entry; - else - SC_Last := SC_Last + 1; - end if; + ----------------------------- + -- Process_Decisions_Defer -- + ----------------------------- - -- Make new entry + procedure Process_Decisions_Defer (N : Node_Id; T : Character) is + begin + SD.Append ((N, No_List, T)); + end Process_Decisions_Defer; - Sloc_Range (From, SC_Array (SC_Last).From, Dummy); - Sloc_Range (To, Dummy, SC_Array (SC_Last).To); - SC_Array (SC_Last).Typ := Typ; - end Extend_Statement_Sequence; + procedure Process_Decisions_Defer (L : List_Id; T : Character) is + begin + SD.Append ((Empty, L, T)); + end Process_Decisions_Defer; -- Start of processing for Traverse_Declarations_Or_Statements begin if Is_Non_Empty_List (L) then - SC_Last := 0; -- Loop through statements or declarations @@ -915,17 +1131,18 @@ package body Par_SCO is -- Subprogram declaration when N_Subprogram_Declaration => - Set_Statement_Entry; - Process_Decisions + Process_Decisions_Defer (Parameter_Specifications (Specification (N)), 'X'); + Set_Statement_Entry; -- Generic subprogram declaration when N_Generic_Subprogram_Declaration => - Set_Statement_Entry; - Process_Decisions (Generic_Formal_Declarations (N), 'X'); - Process_Decisions + Process_Decisions_Defer + (Generic_Formal_Declarations (N), 'X'); + Process_Decisions_Defer (Parameter_Specifications (Specification (N)), 'X'); + Set_Statement_Entry; -- Subprogram_Body @@ -940,8 +1157,8 @@ package body Par_SCO is when N_Exit_Statement => Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Condition (N), 'E'); Set_Statement_Entry; - Process_Decisions (Condition (N), 'E'); -- Label, which breaks the current statement sequence, but the -- label itself is not included in the next statement sequence, @@ -963,16 +1180,33 @@ package body Par_SCO is when N_If_Statement => Extend_Statement_Sequence (N, Condition (N), 'I'); + Process_Decisions_Defer (Condition (N), 'I'); Set_Statement_Entry; - Process_Decisions (Condition (N), 'I'); + + -- Now we traverse the statements in the THEN part + Traverse_Declarations_Or_Statements (Then_Statements (N)); + -- Loop through ELSIF parts if present + if Present (Elsif_Parts (N)) then declare Elif : Node_Id := First (Elsif_Parts (N)); + begin while Present (Elif) loop - Process_Decisions (Condition (Elif), 'I'); + + -- We generate a statement sequence for the + -- construct "ELSIF condition", so that we have + -- a statement for the resulting decisions. + + Extend_Statement_Sequence + (Elif, Condition (Elif), 'I'); + Process_Decisions_Defer (Condition (Elif), 'I'); + Set_Statement_Entry; + + -- Traverse the statements in the ELSIF + Traverse_Declarations_Or_Statements (Then_Statements (Elif)); Next (Elif); @@ -980,6 +1214,8 @@ package body Par_SCO is end; end if; + -- Finally traverse the ELSE statements if present + Traverse_Declarations_Or_Statements (Else_Statements (N)); -- Case statement, which breaks the current statement sequence, @@ -987,14 +1223,13 @@ package body Par_SCO is when N_Case_Statement => Extend_Statement_Sequence (N, Expression (N), 'C'); + Process_Decisions_Defer (Expression (N), 'X'); Set_Statement_Entry; - Process_Decisions (Expression (N), 'X'); -- Process case branches declare Alt : Node_Id; - begin Alt := First (Alternatives (N)); while Present (Alt) loop @@ -1017,22 +1252,17 @@ package body Par_SCO is when N_Simple_Return_Statement => Extend_Statement_Sequence (N, ' '); + Process_Decisions_Defer (Expression (N), 'X'); Set_Statement_Entry; - Process_Decisions (Expression (N), 'X'); -- Extended return statement when N_Extended_Return_Statement => - declare - Odecl : constant Node_Id := - First (Return_Object_Declarations (N)); - begin - if Present (Expression (Odecl)) then - Extend_Statement_Sequence - (N, Expression (Odecl), 'R'); - Process_Decisions (Expression (Odecl), 'X'); - end if; - end; + Extend_Statement_Sequence + (N, Last (Return_Object_Declarations (N)), 'R'); + Process_Decisions_Defer + (Return_Object_Declarations (N), 'X'); + Set_Statement_Entry; Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N)); @@ -1057,13 +1287,13 @@ package body Par_SCO is if Present (Condition (ISC)) then Extend_Statement_Sequence (N, ISC, 'W'); - Process_Decisions (Condition (ISC), 'W'); + Process_Decisions_Defer (Condition (ISC), 'W'); -- For statement else Extend_Statement_Sequence (N, ISC, 'F'); - Process_Decisions + Process_Decisions_Defer (Loop_Parameter_Specification (ISC), 'X'); end if; end; @@ -1077,42 +1307,55 @@ package body Par_SCO is when N_Pragma => Extend_Statement_Sequence (N, 'P'); - -- For pragmas Assert, Check, Precondition, and - -- Postcondition, we generate decision entries for the - -- condition only if the pragma is enabled. For now, we just - -- check Assertions_Enabled, which will be set to reflect - -- the presence of -gnata. + -- Processing depends on the kind of pragma - -- Later we should move processing of the relevant pragmas - -- to Par_Prag, and properly set the flag Pragma_Enabled at - -- parse time, so that we can check this flag instead ??? + case Pragma_Name (N) is + when Name_Assert | + Name_Check | + Name_Precondition | + Name_Postcondition => - -- For all other pragmas, we always generate decision - -- entries for any embedded expressions. + -- For Assert/Check/Precondition/Postcondition, we + -- must generate a P entry for the decision. Note that + -- this is done unconditionally at this stage. Output + -- for disabled pragmas is suppressed later on, when + -- we output the decision line in Put_SCOs. - declare - Nam : constant Name_Id := - Chars (Pragma_Identifier (N)); - Arg : Node_Id := First (Pragma_Argument_Associations (N)); - begin - case Nam is - when Name_Assert | - Name_Check | - Name_Precondition | - Name_Postcondition => + declare + Nam : constant Name_Id := + Chars (Pragma_Identifier (N)); + Arg : Node_Id := + First (Pragma_Argument_Associations (N)); + begin if Nam = Name_Check then Next (Arg); end if; - if Assertions_Enabled then - Process_Decisions (Expression (Arg), 'P'); - end if; + Process_Decisions_Defer (Expression (Arg), 'P'); + end; - when others => - Process_Decisions (N, 'X'); - end case; - end; + -- For all other pragmas, we generate decision entries + -- for any embedded expressions. + + when others => + Process_Decisions_Defer (N, 'X'); + end case; + + -- Object declaration. Ignored if Prev_Ids is set, since the + -- parser generates multiple instances of the whole declaration + -- if there is more than one identifier declared, and we only + -- want one entry in the SCO's, so we take the first, for which + -- Prev_Ids is False. + + when N_Object_Declaration => + if not Prev_Ids (N) then + Extend_Statement_Sequence (N, 'o'); + + if Has_Decision (N) then + Process_Decisions_Defer (N, 'X'); + end if; + end if; -- All other cases, which extend the current statement sequence -- but do not terminate it, even if they have nested decisions. @@ -1135,9 +1378,6 @@ package body Par_SCO is when N_Subtype_Declaration => Typ := 's'; - when N_Object_Declaration => - Typ := 'o'; - when N_Renaming_Declaration => Typ := 'r'; @@ -1154,7 +1394,7 @@ package body Par_SCO is -- Process any embedded decisions if Has_Decision (N) then - Process_Decisions (N, 'X'); + Process_Decisions_Defer (N, 'X'); end if; end case; @@ -1165,6 +1405,30 @@ package body Par_SCO is end if; end Traverse_Declarations_Or_Statements; + ------------------------------------ + -- Traverse_Generic_Instantiation -- + ------------------------------------ + + procedure Traverse_Generic_Instantiation (N : Node_Id) is + First : Source_Ptr; + Last : Source_Ptr; + + begin + -- First we need a statement entry to cover the instantiation + + Sloc_Range (N, First, Last); + Set_Table_Entry + (C1 => 'S', + C2 => ' ', + From => First, + To => Last, + Last => True); + + -- Now output any embedded decisions + + Process_Decisions (N, 'X'); + end Traverse_Generic_Instantiation; + ------------------------------------------ -- Traverse_Generic_Package_Declaration -- ------------------------------------------ @@ -1183,7 +1447,6 @@ package body Par_SCO is Handler : Node_Id; begin - -- For package bodies without a statement part, the parser adds an empty -- one, to normalize the representation. The null statement therein, -- which does not come from source, does not get a SCO. @@ -1232,4 +1495,16 @@ package body Par_SCO is Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N)); end Traverse_Subprogram_Body; + ------------------------------------- + -- Traverse_Subprogram_Declaration -- + ------------------------------------- + + procedure Traverse_Subprogram_Declaration (N : Node_Id) is + ADN : constant Node_Id := Aux_Decls_Node (Parent (N)); + begin + Traverse_Declarations_Or_Statements (Config_Pragmas (ADN)); + Traverse_Declarations_Or_Statements (Declarations (ADN)); + Traverse_Declarations_Or_Statements (Pragmas_After (ADN)); + end Traverse_Subprogram_Declaration; + end Par_SCO; diff --git a/gcc/ada/par_sco.ads b/gcc/ada/par_sco.ads index 6cb68a71441..97e4a6a61af 100644 --- a/gcc/ada/par_sco.ads +++ b/gcc/ada/par_sco.ads @@ -25,156 +25,12 @@ -- This package contains the routines used to deal with generation and output -- of Soure Coverage Obligations (SCO's) used for coverage analysis purposes. +-- See package SCOs for full documentation of format of SCO information. with Types; use Types; package Par_SCO is - ---------------- - -- SCO Format -- - ---------------- - - -- Source coverage obligations are generated on a unit-by-unit basis in the - -- ALI file, using lines that start with the identifying character C. These - -- lines are generated if the -gnatC switch is set. - - -- Sloc Ranges - - -- In several places in the SCO lines, Sloc ranges appear. These are used - -- to indicate the first and last Sloc of some construct in the tree and - -- they have the form: - - -- line:col-line:col - - -- Note that SCO's are generated only for generic templates, not for - -- generic instances (since only the first are part of the source). So - -- we don't need generic instantiation stuff in these line:col items. - - -- SCO File headers - - -- The SCO information follows the cross-reference information, so it - -- need not be read by tools like gnatbind, gnatmake etc. The SCO output - -- is divided into sections, one section for each unit for which SCO's - -- are generated. A SCO section has a header of the form: - - -- C dependency-number filename - - -- This header precedes SCO information for the unit identified by - -- dependency number and file name. The dependency number is the - -- index into the generated D lines and is ones origin (i.e. 2 = - -- reference to second generated D line). - - -- Note that the filename here will reflect the original name if - -- a Source_Reference pragma was encountered (since all line number - -- references will be with respect to the original file). - - -- Statements - - -- For the purpose of SCO generation, the notion of statement includes - -- simple statements and also the following declaration types: - - -- type_declaration - -- subtype_declaration - -- object_declaration - -- renaming_declaration - -- generic_instantiation - - -- Statement lines - - -- These lines correspond to a sequence of one or more statements which - -- are always exeecuted in sequence, The first statement may be an entry - -- point (e.g. statement after a label), and the last statement may be - -- an exit point (e.g. an exit statement), but no other entry or exit - -- points may occur within the sequence of statements. The idea is that - -- the sequence can be treated as a single unit from a coverage point of - -- view, if any of the code for the statement sequence is executed, this - -- corresponds to coverage of the entire statement sequence. The form of - -- a statement line in the ALI file is: - - -- CS sloc-range - - -- Exit points - - -- An exit point is a statement that causes transfer of control. Examples - -- are exit statements, raise statements and return statements. The form - -- of an exit point in the ALI file is: - - -- CT sloc-range - - -- Decisions - - -- Decisions represent the most significant section of the SCO lines - - -- Note: in the following description, logical operator includes the - -- short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN, - -- or OR ELSE). - - -- Decisions are either simple or complex. A simple decision is a boolean - -- expresssion that occurs in the context of a control structure in the - -- source program, including WHILE, IF, EXIT WHEN. Note that a boolean - -- expression in any other context, e.g. on the right side of an - -- assignment, is not considered to be a decision. - - -- A complex decision is an occurrence of a logical operator which is not - -- itself an operand of some other logical operator. If any operand of - -- the logical operator is itself a logical operator, this is not a - -- separate decision, it is part of the same decision. - - -- So for example, if we have - - -- A, B, C, D : Boolean; - -- function F (Arg : Boolean) return Boolean); - -- ... - -- A and then (B or else F (C and then D)) - - -- There are two (complex) decisions here: - - -- 1. X and then (Y or else Z) - - -- where X = A, Y = B, and Z = F (C and then D) - - -- 2. C and then D - - -- For each decision, a decision line is generated with the form: - - -- C* expression - - -- Here * is one of the following characters: - - -- I decision in IF statement or conditional expression - -- E decision in EXIT WHEN statement - -- W decision in WHILE iteration scheme - -- X decision appearing in some other expression context - - -- The expression is a prefix polish form indicating the structure of - -- the decision, including logical operators and short circuit forms. - -- The following is a grammar showing the structure of expression: - - -- expression ::= term (if expr is not logical operator) - -- expression ::= & term term (if expr is AND THEN) - -- expression ::= | term term (if expr is OR ELSE) - -- expression ::= !term (if expr is NOT) - - -- term ::= element - -- term ::= expression - - -- element ::= outcome sloc-range - - -- outcome is one of the following letters: - - -- c condition - -- t true condition - -- f false condition - - -- where t/f are used to mark a condition that has been recognized by - -- the compiler as always being true or false. - - -- & indicates either AND THEN connecting two conditions - - -- | indicates either OR ELSE connection two conditions - - -- ! indicates NOT applied to the expression - ----------------- -- Subprograms -- ----------------- @@ -187,11 +43,19 @@ package Par_SCO is -- internal tables recording the SCO information. Note that this is done -- before any semantic analysis/expansion happens. - procedure Set_SCO_Condition (First_Loc : Source_Ptr; Typ : Character); + procedure Set_SCO_Condition (Cond : Node_Id; Val : Boolean); -- This procedure is called during semantic analysis to record a condition - -- which has been identified as always True (Typ = 't') or always False - -- (Typ = 'f') by the compiler. The condition is identified by the - -- First_Sloc value in the original tree. + -- which has been identified as always True or always False, as indicated + -- by Val. The condition is identified by the First_Sloc value in the + -- original tree associated with Cond. + + procedure Set_SCO_Pragma_Enabled (Loc : Source_Ptr); + -- This procedure is called from Sem_Prag when a pragma is enabled (i.e. + -- when the Pragma_Enabled flag is set). Loc is the Sloc of the N_Pragma + -- node. This is used to enable the corresponding SCO table entry. Note + -- that we use the Sloc as the key here, since in the generic case, the + -- analysis is on a copy of the node, which is different from the node + -- seen by Par_SCO in the parse tree (but the Sloc values are the same). procedure SCO_Output; -- Outputs SCO lines for all units, with appropriate section headers, for @@ -199,8 +63,8 @@ package Par_SCO is -- possibly modified by calls to Set_SCO_Condition. procedure dsco; - -- Debug routine to dump SCO table. This is a raw format dump showing - -- exactly what the tables contain. + -- Debug routine to dump internal SCO table. This is a raw format dump + -- showing exactly what the table contains. procedure pscos; -- Debugging procedure to output contents of SCO binary tables in the diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index 9a76dc94730..2fb64cc614d 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -411,7 +411,8 @@ package body Prep is Scan.all; else - Error_Msg ("`)` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`)` expected", Token_Ptr); end if; when Tok_Not => @@ -906,7 +907,8 @@ package body Prep is Scan.all; if Token /= Tok_Colon_Equal then - Error_Msg ("`:=` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`:=` expected", Token_Ptr); goto Cleanup; end if; @@ -1219,7 +1221,8 @@ package body Prep is elsif Pp_States.Table (Pp_States.Last).Else_Ptr /= 0 then - Error_Msg ("duplicate ELSE line", Token_Ptr); + Error_Msg -- CODEFIX + ("duplicate ELSE line", Token_Ptr); No_Error_Found := False; end if; @@ -1269,14 +1272,16 @@ package body Prep is Scan.all; if Token /= Tok_If then - Error_Msg ("IF expected", Token_Ptr); + Error_Msg -- CODEFIX + ("IF expected", Token_Ptr); No_Error_Found := False; else Scan.all; if Token /= Tok_Semicolon then - Error_Msg ("`;` Expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`;` Expected", Token_Ptr); No_Error_Found := False; else @@ -1312,13 +1317,15 @@ package body Prep is No_Error_Found := False; if Pp_States.Last = 0 then - Error_Msg ("IF expected", Token_Ptr); + Error_Msg -- CODEFIX + ("IF expected", Token_Ptr); elsif Pp_States.Table (Pp_States.Last).Else_Ptr = 0 then - Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected", - Token_Ptr); + Error_Msg + ("IF, ELSIF, ELSE, or `END IF` expected", + Token_Ptr); else Error_Msg ("IF or `END IF` expected", Token_Ptr); diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb index ad14fc5e164..e36d59944ca 100644 --- a/gcc/ada/prepcomp.adb +++ b/gcc/ada/prepcomp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, 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- -- @@ -342,7 +342,8 @@ package body Prepcomp is while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop if Token /= Tok_Minus then - Error_Msg ("`'-` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`'-` expected", Token_Ptr); Skip_To_End_Of_Line; goto Scan_Line; end if; @@ -463,7 +464,8 @@ package body Prepcomp is Scan; if Token /= Tok_Equal then - Error_Msg ("`=` expected", Token_Ptr); + Error_Msg -- CODEFIX + ("`=` expected", Token_Ptr); Skip_To_End_Of_Line; goto Scan_Line; end if; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index d143a504a84..2e9255c47d2 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -71,7 +71,6 @@ package body Prj.Attr is "SVRproject_dir#" & "lVmain#" & "LVlanguages#" & - "SVmain_language#" & "Lbroots#" & "SVexternally_built#" & diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index dfebd9a5d49..7ffa8d52b94 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,23 +23,25 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Directories; use Ada.Directories; -with GNAT.HTable; use GNAT.HTable; -with Makeutl; use Makeutl; +with Hostparm; +with Makeutl; use Makeutl; with MLib.Tgt; -with Opt; use Opt; -with Output; use Output; +with Opt; use Opt; +with Output; use Output; with Prj.Env; with Prj.Err; with Prj.Part; with Prj.PP; -with Prj.Proc; use Prj.Proc; -with Prj.Tree; use Prj.Tree; -with Prj.Util; use Prj.Util; -with Prj; use Prj; -with Snames; use Snames; -with System.Case_Util; use System.Case_Util; -with System; +with Prj.Proc; use Prj.Proc; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Prj; use Prj; +with Snames; use Snames; + +with Ada.Directories; use Ada.Directories; + +with GNAT.Case_Util; use GNAT.Case_Util; +with GNAT.HTable; use GNAT.HTable; package body Prj.Conf is @@ -889,8 +891,18 @@ package body Prj.Conf is <<Process_Config_File>> if Automatically_Generated then - -- This might raise an Invalid_Config exception - Do_Autoconf; + if Hostparm.OpenVMS then + + -- There is no gprconfig on VMS + + raise Invalid_Config + with "could not locate any configuration project file"; + + else + -- This might raise an Invalid_Config exception + + Do_Autoconf; + end if; end if; -- Parse the configuration file diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb index f7fc668dd8f..39bda01987e 100644 --- a/gcc/ada/prj-env.adb +++ b/gcc/ada/prj-env.adb @@ -1498,7 +1498,9 @@ package body Prj.Env is procedure Set_Ada_Paths (Project : Project_Id; In_Tree : Project_Tree_Ref; - Including_Libraries : Boolean) + Including_Libraries : Boolean; + Include_Path : Boolean := True; + Objects_Path : Boolean := True) is Source_Paths : Source_Path_Table.Instance; @@ -1570,7 +1572,7 @@ package body Prj.Env is -- If it is the first time we call this procedure for this project, -- compute the source path and/or the object path. - if Project.Include_Path_File = No_Path then + if Include_Path and then Project.Include_Path_File = No_Path then Source_Path_Table.Init (Source_Paths); Process_Source_Dirs := True; Create_New_Path_File @@ -1580,7 +1582,7 @@ package body Prj.Env is -- For the object path, we make a distinction depending on -- Including_Libraries. - if Including_Libraries then + if Objects_Path and Including_Libraries then if Project.Objects_Path_File_With_Libs = No_Path then Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; @@ -1588,7 +1590,7 @@ package body Prj.Env is (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs); end if; - else + elsif Objects_Path then if Project.Objects_Path_File_Without_Libs = No_Path then Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; @@ -1662,7 +1664,8 @@ package body Prj.Env is -- Set the env vars, if they need to be changed, and set the -- corresponding flags. - if In_Tree.Private_Part.Current_Source_Path_File /= + if Include_Path and then + In_Tree.Private_Part.Current_Source_Path_File /= Project.Include_Path_File then In_Tree.Private_Part.Current_Source_Path_File := @@ -1672,28 +1675,30 @@ package body Prj.Env is Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File)); end if; - if Including_Libraries then - if In_Tree.Private_Part.Current_Object_Path_File /= - Project.Objects_Path_File_With_Libs - then - In_Tree.Private_Part.Current_Object_Path_File := - Project.Objects_Path_File_With_Libs; - Set_Path_File_Var - (Project_Objects_Path_File, - Get_Name_String - (In_Tree.Private_Part.Current_Object_Path_File)); - end if; + if Objects_Path then + if Including_Libraries then + if In_Tree.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_With_Libs + then + In_Tree.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_With_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (In_Tree.Private_Part.Current_Object_Path_File)); + end if; - else - if In_Tree.Private_Part.Current_Object_Path_File /= - Project.Objects_Path_File_Without_Libs - then - In_Tree.Private_Part.Current_Object_Path_File := - Project.Objects_Path_File_Without_Libs; - Set_Path_File_Var - (Project_Objects_Path_File, - Get_Name_String - (In_Tree.Private_Part.Current_Object_Path_File)); + else + if In_Tree.Private_Part.Current_Object_Path_File /= + Project.Objects_Path_File_Without_Libs + then + In_Tree.Private_Part.Current_Object_Path_File := + Project.Objects_Path_File_Without_Libs; + Set_Path_File_Var + (Project_Objects_Path_File, + Get_Name_String + (In_Tree.Private_Part.Current_Object_Path_File)); + end if; end if; end if; diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads index 27259c29b98..9dcde328038 100644 --- a/gcc/ada/prj-env.ads +++ b/gcc/ada/prj-env.ads @@ -94,7 +94,9 @@ package Prj.Env is procedure Set_Ada_Paths (Project : Project_Id; In_Tree : Project_Tree_Ref; - Including_Libraries : Boolean); + Including_Libraries : Boolean; + Include_Path : Boolean := True; + Objects_Path : Boolean := True); -- Set the environment variables for additional project path files, after -- creating the path files if necessary. diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb index fe6216f82fa..51da2a3e82c 100644 --- a/gcc/ada/prj-ext.adb +++ b/gcc/ada/prj-ext.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with System.OS_Lib; use System.OS_Lib; with Hostparm; with Makeutl; use Makeutl; with Opt; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 7dc8ad3250f..b502b2aebc9 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, 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- -- @@ -26,6 +26,7 @@ with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Dynamic_HTables; +with GNAT.Table; with Err_Vars; use Err_Vars; with Opt; use Opt; @@ -54,10 +55,17 @@ package body Prj.Nmsc is Name : File_Name_Type; -- ??? duplicates the key Location : Source_Ptr; Source : Source_Id := No_Source; + Listed : Boolean := False; Found : Boolean := False; end record; + No_Name_Location : constant Name_Location := - (No_File, No_Location, No_Source, False); + (Name => No_File, + Location => No_Location, + Source => No_Source, + Listed => False, + Found => False); + package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Name_Location, @@ -65,11 +73,10 @@ package body Prj.Nmsc is Key => File_Name_Type, Hash => Hash, Equal => "="); - -- Information about file names found in string list attribute - -- (Source_Files or Source_List_File). - -- Except is set to True if source is a naming exception in the project. - -- This is used to check that all referenced files were indeed found on the - -- disk. + -- File name information found in string list attribute (Source_Files or + -- Source_List_File). Except is set to True if source is a naming exception + -- in the project. Used to check that all referenced files were indeed + -- found on the disk. type Unit_Exception is record Name : Name_Id; -- ??? duplicates the key @@ -151,6 +158,20 @@ package body Prj.Nmsc is -- This data must be initialized before processing any project, and the -- same data is used for processing all projects in the tree. + type Lib_Data is record + Name : Name_Id; + Proj : Project_Id; + end record; + + package Lib_Data_Table is new GNAT.Table + (Table_Component_Type => Lib_Data, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100); + -- A table to record library names in order to check that two library + -- projects do not have the same library names. + procedure Initialize (Data : out Tree_Processing_Data; Tree : Project_Tree_Ref; @@ -234,13 +255,9 @@ package body Prj.Nmsc is procedure Check_Package_Naming (Project : Project_Id; - Data : in out Tree_Processing_Data; - Bodies : out Array_Element_Id; - Specs : out Array_Element_Id); + Data : in out Tree_Processing_Data); -- Check the naming scheme part of Data, and initialize the naming scheme - -- data in the config of the various languages. This also returns the - -- naming scheme exceptions for unit-based languages (Bodies and Specs are - -- associative arrays mapping individual unit names to source file names). + -- data in the config of the various languages. procedure Check_Configuration (Project : Project_Id; @@ -298,6 +315,7 @@ package body Prj.Nmsc is Data : in out Tree_Processing_Data; Source_Dir_Rank : Natural; Path : Path_Name_Type; + Display_Path : Path_Name_Type; File_Name : File_Name_Type; Display_File_Name : File_Name_Type; Locally_Removed : Boolean; @@ -307,11 +325,12 @@ package body Prj.Nmsc is -- schemes, it is added to various htables through Add_Source and to -- Source_Paths_Htable. -- - -- Name is the name of the candidate file. It hasn't been normalized yet - -- and is the direct result of readdir(). + -- File_Name is the same as Display_File_Name, but has been normalized. + -- They do not include the directory information. -- - -- File_Name is the same as Name, but has been normalized. - -- Display_File_Name, however, has not been normalized. + -- Path and Display_Path on the other hand are the full path to the file. + -- Path must have been normalized (canonical casing and possibly links + -- resolved). -- -- Source_Directory is the directory in which the file was found. It is -- neither normalized nor has had links resolved, and must not end with a @@ -448,6 +467,32 @@ package body Prj.Nmsc is -- Debug print a value for a specific property. Does nothing when not in -- debug mode + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id); + -- Emits either an error or warning message (or nothing), depending on Kind + + ---------------------- + -- Error_Or_Warning -- + ---------------------- + + procedure Error_Or_Warning + (Flags : Processing_Flags; + Kind : Error_Warning; + Msg : String; + Location : Source_Ptr; + Project : Project_Id) is + begin + case Kind is + when Error => Error_Msg (Flags, Msg, Location, Project); + when Warning => Error_Msg (Flags, "?" & Msg, Location, Project); + when Silent => null; + end case; + end Error_Or_Warning; + ------------------------------ -- Replace_Into_Name_Buffer -- ------------------------------ @@ -701,7 +746,7 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Str ("Adding source File: "); - Write_Str (Get_Name_String (File_Name)); + Write_Str (Get_Name_String (Display_File)); if Index /= 0 then Write_Str (" at" & Index'Img); @@ -725,6 +770,7 @@ package body Prj.Nmsc is end if; Id.Project := Project; + Id.Location := Location; Id.Source_Dir_Rank := Source_Dir_Rank; Id.Language := Lang_Id; Id.Kind := Kind; @@ -811,11 +857,9 @@ package body Prj.Nmsc is ----------- procedure Check - (Project : Project_Id; - Data : in out Tree_Processing_Data) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is - Specs : Array_Element_Id; - Bodies : Array_Element_Id; Extending : Boolean := False; Prj_Data : Project_Processing_Data; @@ -887,7 +931,7 @@ package body Prj.Nmsc is Extending := Project.Extends /= No_Project; - Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs); + Check_Package_Naming (Project, Data); -- Find the sources @@ -1836,6 +1880,9 @@ package body Prj.Nmsc is elsif Name = Name_Gnu then Project.Config.Resp_File_Format := GNU; + elsif Name_Buffer (1 .. Name_Len) = "gcc" then + Project.Config.Resp_File_Format := GCC; + elsif Name = Name_Object_List then Project.Config.Resp_File_Format := Object_List; @@ -2717,9 +2764,7 @@ package body Prj.Nmsc is procedure Check_Package_Naming (Project : Project_Id; - Data : in out Tree_Processing_Data; - Bodies : out Array_Element_Id; - Specs : out Array_Element_Id) + Data : in out Tree_Processing_Data) is Naming_Id : constant Package_Id := Util.Value_Of @@ -2952,7 +2997,8 @@ package body Prj.Nmsc is Kind => Kind, File_Name => File_Name, Display_File => File_Name_Type (Element.Value), - Naming_Exception => True); + Naming_Exception => True, + Location => Element.Location); else -- Check if the file name is already recorded for another @@ -3375,9 +3421,6 @@ package body Prj.Nmsc is -- Start of processing for Check_Naming_Schemes begin - Specs := No_Array_Element; - Bodies := No_Array_Element; - -- No Naming package or parsing a configuration file? nothing to do if Naming_Id /= No_Package @@ -3631,99 +3674,103 @@ package body Prj.Nmsc is "library directory { does not exist", Lib_Dir.Location, Project); + elsif not Project.Externally_Built then + -- The library directory cannot be the same as the Object -- directory. - elsif Project.Library_Dir.Name = Project.Object_Directory.Name then - Error_Msg - (Data.Flags, - "library directory cannot be the same " & - "as object directory", - Lib_Dir.Location, Project); - Project.Library_Dir := No_Path_Information; - - else - declare - OK : Boolean := True; - Dirs_Id : String_List_Id; - Dir_Elem : String_Element; - Pid : Project_List; - - begin - -- The library directory cannot be the same as a source - -- directory of the current project. - - Dirs_Id := Project.Source_Dirs; - while Dirs_Id /= Nil_String loop - Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; - - if Project.Library_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Error_Msg - (Data.Flags, - "library directory cannot be the same " & - "as source directory {", - Lib_Dir.Location, Project); - OK := False; - exit; - end if; - end loop; + if Project.Library_Dir.Name = Project.Object_Directory.Name then + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as object directory", + Lib_Dir.Location, Project); + Project.Library_Dir := No_Path_Information; - if OK then + else + declare + OK : Boolean := True; + Dirs_Id : String_List_Id; + Dir_Elem : String_Element; + Pid : Project_List; + begin -- The library directory cannot be the same as a source - -- directory of another project either. + -- directory of the current project. - Pid := Data.Tree.Projects; - Project_Loop : loop - exit Project_Loop when Pid = null; + Dirs_Id := Project.Source_Dirs; + while Dirs_Id /= Nil_String loop + Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; - if Pid.Project /= Project then - Dirs_Id := Pid.Project.Source_Dirs; + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Error_Msg + (Data.Flags, + "library directory cannot be the same " & + "as source directory {", + Lib_Dir.Location, Project); + OK := False; + exit; + end if; + end loop; - Dir_Loop : while Dirs_Id /= Nil_String loop - Dir_Elem := - Data.Tree.String_Elements.Table (Dirs_Id); - Dirs_Id := Dir_Elem.Next; + if OK then - if Project.Library_Dir.Name = - Path_Name_Type (Dir_Elem.Value) - then - Err_Vars.Error_Msg_File_1 := - File_Name_Type (Dir_Elem.Value); - Err_Vars.Error_Msg_Name_1 := Pid.Project.Name; + -- The library directory cannot be the same as a + -- source directory of another project either. - Error_Msg - (Data.Flags, - "library directory cannot be the same " & - "as source directory { of project %%", - Lib_Dir.Location, Project); - OK := False; - exit Project_Loop; - end if; - end loop Dir_Loop; - end if; + Pid := Data.Tree.Projects; + Project_Loop : loop + exit Project_Loop when Pid = null; - Pid := Pid.Next; - end loop Project_Loop; - end if; + if Pid.Project /= Project then + Dirs_Id := Pid.Project.Source_Dirs; + + Dir_Loop : while Dirs_Id /= Nil_String loop + Dir_Elem := + Data.Tree.String_Elements.Table (Dirs_Id); + Dirs_Id := Dir_Elem.Next; + + if Project.Library_Dir.Name = + Path_Name_Type (Dir_Elem.Value) + then + Err_Vars.Error_Msg_File_1 := + File_Name_Type (Dir_Elem.Value); + Err_Vars.Error_Msg_Name_1 := + Pid.Project.Name; + + Error_Msg + (Data.Flags, + "library directory cannot be the same" & + " as source directory { of project %%", + Lib_Dir.Location, Project); + OK := False; + exit Project_Loop; + end if; + end loop Dir_Loop; + end if; - if not OK then - Project.Library_Dir := No_Path_Information; + Pid := Pid.Next; + end loop Project_Loop; + end if; - elsif Current_Verbosity = High then + if not OK then + Project.Library_Dir := No_Path_Information; - -- Display the Library directory in high verbosity + elsif Current_Verbosity = High then - Write_Attr - ("Library directory", - Get_Name_String (Project.Library_Dir.Display_Name)); - end if; - end; + -- Display the Library directory in high verbosity + + Write_Attr + ("Library directory", + Get_Name_String (Project.Library_Dir.Display_Name)); + end if; + end; + end if; end if; end if; @@ -3811,8 +3858,9 @@ package body Prj.Nmsc is Lib_ALI_Dir.Location, Project); end if; - if Project.Library_ALI_Dir /= Project.Library_Dir then - + if (not Project.Externally_Built) and then + Project.Library_ALI_Dir /= Project.Library_Dir + then -- The library ALI directory cannot be the same as the -- Object directory. @@ -4076,9 +4124,46 @@ package body Prj.Nmsc is end; end if; - if Project.Extends /= No_Project then + if Project.Extends /= No_Project and then Project.Extends.Library then + + -- Remove the library name from Lib_Data_Table + + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Proj = Project.Extends then + Lib_Data_Table.Table (J) := + Lib_Data_Table.Table (Lib_Data_Table.Last); + Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1); + exit; + end if; + end loop; + Project.Extends.Library := False; end if; + + if Project.Library and then not Lib_Name.Default then + + -- Check if the same library name is used in an other library project + + for J in 1 .. Lib_Data_Table.Last loop + if Lib_Data_Table.Table (J).Name = Project.Library_Name then + Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name; + Error_Msg + (Data.Flags, + "Library name cannot be the same as in project %%", + Lib_Name.Location, Project); + Project.Library := False; + exit; + end if; + end loop; + end if; + + if Project.Library then + + -- Record the library name + + Lib_Data_Table.Append + ((Name => Project.Library_Name, Proj => Project)); + end if; end Check_Library_Attributes; --------------------------------- @@ -4778,14 +4863,14 @@ package body Prj.Nmsc is --------------------- procedure Get_Directories - (Project : Project_Id; - Data : in out Tree_Processing_Data) + (Project : Project_Id; + Data : in out Tree_Processing_Data) is package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, - Key => Name_Id, + Key => Path_Name_Type, Hash => Hash, Equal => "="); -- Hash table stores recursive source directories, to avoid looking @@ -4832,123 +4917,127 @@ package body Prj.Nmsc is -- Find one or several source directories, and add (or remove, if -- Removed is True) them to list of source directories of the project. - ---------------------- - -- Find_Source_Dirs -- - ---------------------- - - procedure Find_Source_Dirs - (From : File_Name_Type; - Location : Source_Ptr; - Rank : Natural; - Removed : Boolean := False) + procedure Add_To_Or_Remove_From_Source_Dirs + (Path_Id : Path_Name_Type; + Display_Path_Id : Path_Name_Type; + Rank : Natural; + Removed : Boolean); + -- When Removed = False, the directory Path_Id to the list of + -- source_dirs if not already in the list. When Removed = True, + -- removed directory Path_Id if in the list. + + --------------------------------------- + -- Add_To_Or_Remove_From_Source_Dirs -- + --------------------------------------- + + procedure Add_To_Or_Remove_From_Source_Dirs + (Path_Id : Path_Name_Type; + Display_Path_Id : Path_Name_Type; + Rank : Natural; + Removed : Boolean) is - Directory : constant String := Get_Name_String (From); + List : String_List_Id; + Prev : String_List_Id; + Rank_List : Number_List_Index; + Prev_Rank : Number_List_Index; + Element : String_Element; - procedure Add_To_Or_Remove_From_List - (Path_Id : Name_Id; - Display_Path_Id : Name_Id); - -- When Removed = False, the directory Path_Id to the list of - -- source_dirs if not already in the list. When Removed = True, - -- removed directory Path_Id if in the list. + begin + Prev := Nil_String; + Prev_Rank := No_Number_List; + List := Project.Source_Dirs; + Rank_List := Project.Source_Dir_Ranks; + while List /= Nil_String loop + Element := Data.Tree.String_Elements.Table (List); + exit when Element.Value = Name_Id (Path_Id); + Prev := List; + List := Element.Next; + Prev_Rank := Rank_List; + Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next; + end loop; - procedure Recursive_Find_Dirs (Path : Name_Id); - -- Find all the subdirectories (recursively) of Path and add them - -- to the list of source directories of the project. + -- The directory is in the list if List is not Nil_String - -------------------------------- - -- Add_To_Or_Remove_From_List -- - -------------------------------- - - procedure Add_To_Or_Remove_From_List - (Path_Id : Name_Id; - Display_Path_Id : Name_Id) - is - List : String_List_Id; - Prev : String_List_Id; - Rank_List : Number_List_Index; - Prev_Rank : Number_List_Index; - Element : String_Element; + if not Removed and then List = Nil_String then + if Current_Verbosity = High then + Write_Str (" Adding Source Dir="); + Write_Line (Get_Name_String (Display_Path_Id)); + end if; - begin - Prev := Nil_String; - Prev_Rank := No_Number_List; - List := Project.Source_Dirs; - Rank_List := Project.Source_Dir_Ranks; - while List /= Nil_String loop - Element := Data.Tree.String_Elements.Table (List); - exit when Element.Value = Path_Id; - Prev := List; - List := Element.Next; - Prev_Rank := Rank_List; - Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next; - end loop; + String_Element_Table.Increment_Last (Data.Tree.String_Elements); + Element := + (Value => Name_Id (Path_Id), + Index => 0, + Display_Value => Name_Id (Display_Path_Id), + Location => No_Location, + Flag => False, + Next => Nil_String); - -- The directory is in the list if List is not Nil_String + Number_List_Table.Increment_Last (Data.Tree.Number_Lists); - if not Removed and then List = Nil_String then - if Current_Verbosity = High then - Write_Str (" Adding Source Dir="); - Write_Line (Get_Name_String (Path_Id)); - end if; + if Last_Source_Dir = Nil_String then - String_Element_Table.Increment_Last (Data.Tree.String_Elements); - Element := - (Value => Path_Id, - Index => 0, - Display_Value => Display_Path_Id, - Location => No_Location, - Flag => False, - Next => Nil_String); + -- This is the first source directory - Number_List_Table.Increment_Last (Data.Tree.Number_Lists); + Project.Source_Dirs := + String_Element_Table.Last (Data.Tree.String_Elements); + Project.Source_Dir_Ranks := + Number_List_Table.Last (Data.Tree.Number_Lists); - if Last_Source_Dir = Nil_String then + else + -- We already have source directories, link the previous + -- last to the new one. - -- This is the first source directory + Data.Tree.String_Elements.Table (Last_Source_Dir).Next := + String_Element_Table.Last (Data.Tree.String_Elements); + Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next := + Number_List_Table.Last (Data.Tree.Number_Lists); + end if; - Project.Source_Dirs := - String_Element_Table.Last (Data.Tree.String_Elements); - Project.Source_Dir_Ranks := - Number_List_Table.Last (Data.Tree.Number_Lists); + -- And register this source directory as the new last - else - -- We already have source directories, link the previous - -- last to the new one. + Last_Source_Dir := + String_Element_Table.Last (Data.Tree.String_Elements); + Data.Tree.String_Elements.Table (Last_Source_Dir) := Element; + Last_Src_Dir_Rank := + Number_List_Table.Last (Data.Tree.Number_Lists); + Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) := + (Number => Rank, Next => No_Number_List); - Data.Tree.String_Elements.Table (Last_Source_Dir).Next := - String_Element_Table.Last (Data.Tree.String_Elements); - Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next := - Number_List_Table.Last (Data.Tree.Number_Lists); - end if; + elsif Removed and then List /= Nil_String then - -- And register this source directory as the new last + -- Remove source dir, if present - Last_Source_Dir := - String_Element_Table.Last (Data.Tree.String_Elements); - Data.Tree.String_Elements.Table (Last_Source_Dir) := Element; - Last_Src_Dir_Rank := - Number_List_Table.Last (Data.Tree.Number_Lists); - Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) := - (Number => Rank, Next => No_Number_List); + if Prev = Nil_String then + Project.Source_Dirs := + Data.Tree.String_Elements.Table (List).Next; + Project.Source_Dir_Ranks := + Data.Tree.Number_Lists.Table (Rank_List).Next; - elsif Removed and then List /= Nil_String then + else + Data.Tree.String_Elements.Table (Prev).Next := + Data.Tree.String_Elements.Table (List).Next; + Data.Tree.Number_Lists.Table (Prev_Rank).Next := + Data.Tree.Number_Lists.Table (Rank_List).Next; + end if; + end if; + end Add_To_Or_Remove_From_Source_Dirs; - -- Remove source dir, if present + ---------------------- + -- Find_Source_Dirs -- + ---------------------- - if Prev = Nil_String then - Project.Source_Dirs := - Data.Tree.String_Elements.Table (List).Next; - Project.Source_Dir_Ranks := - Data.Tree.Number_Lists.Table (Rank_List).Next; + procedure Find_Source_Dirs + (From : File_Name_Type; + Location : Source_Ptr; + Rank : Natural; + Removed : Boolean := False) + is + Directory : constant String := Get_Name_String (From); - else - Data.Tree.String_Elements.Table (Prev).Next := - Data.Tree.String_Elements.Table (List).Next; - Data.Tree.Number_Lists.Table (Prev_Rank).Next := - Data.Tree.Number_Lists.Table (Rank_List).Next; - end if; - end if; - end Add_To_Or_Remove_From_List; + procedure Recursive_Find_Dirs (Path : Name_Id); + -- Find all the subdirectories (recursively) of Path and add them + -- to the list of source directories of the project. ------------------------- -- Recursive_Find_Dirs -- @@ -4959,8 +5048,8 @@ package body Prj.Nmsc is Name : String (1 .. 250); Last : Natural; - Non_Canonical_Path : Name_Id := No_Name; - Canonical_Path : Name_Id := No_Name; + Non_Canonical_Path : Path_Name_Type := No_Path; + Canonical_Path : Path_Name_Type := No_Path; The_Path : constant String := Normalize_Pathname @@ -4979,7 +5068,8 @@ package body Prj.Nmsc is The_Path (The_Path'First .. The_Path_Last); Non_Canonical_Path := Name_Find; Canonical_Path := - Name_Id (Canonical_Case_File_Name (Non_Canonical_Path)); + Path_Name_Type + (Canonical_Case_File_Name (Name_Id (Non_Canonical_Path))); -- To avoid processing the same directory several times, check -- if the directory is already in Recursive_Dirs. If it is, then @@ -4994,9 +5084,11 @@ package body Prj.Nmsc is end if; end if; - Add_To_Or_Remove_From_List + Add_To_Or_Remove_From_Source_Dirs (Path_Id => Canonical_Path, - Display_Path_Id => Non_Canonical_Path); + Display_Path_Id => Non_Canonical_Path, + Rank => Rank, + Removed => Removed); -- Now look for subdirectories. Do that even when this directory -- is already in the list, because some of its subdirectories may @@ -5093,7 +5185,7 @@ package body Prj.Nmsc is Base_Dir : constant File_Name_Type := Name_Find; Root_Dir : constant String := Normalize_Pathname - (Name => Get_Name_String (Base_Dir), + (Name => Name_Buffer (1 .. Name_Len), Directory => Get_Name_String (Project.Directory.Display_Name), @@ -5104,18 +5196,9 @@ package body Prj.Nmsc is begin if Root_Dir'Length = 0 then Err_Vars.Error_Msg_File_1 := Base_Dir; - - if Location = No_Location then - Error_Msg - (Data.Flags, - "{ is not a valid directory.", - Project.Location, Project); - else - Error_Msg - (Data.Flags, - "{ is not a valid directory.", - Location, Project); - end if; + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "{ is not a valid directory.", Location, Project); else -- We have an existing directory, we register it and all of @@ -5153,57 +5236,18 @@ package body Prj.Nmsc is if not Dir_Exists then Err_Vars.Error_Msg_File_1 := From; - - if Location = No_Location then - Error_Msg - (Data.Flags, - "{ is not a valid directory", - Project.Location, Project); - else - Error_Msg - (Data.Flags, - "{ is not a valid directory", - Location, Project); - end if; + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, + "{ is not a valid directory", Location, Project); else - declare - Path : constant String := - Normalize_Pathname - (Name => - Get_Name_String (Path_Name.Name), - Directory => - Get_Name_String (Project.Directory.Name), - Resolve_Links => Opt.Follow_Links_For_Dirs, - Case_Sensitive => True) & - Directory_Separator; - - Last_Path : constant Natural := - Compute_Directory_Last (Path); - Path_Id : Name_Id; - Display_Path : constant String := - Get_Name_String - (Path_Name.Display_Name); - Last_Display_Path : constant Natural := - Compute_Directory_Last - (Display_Path); - Display_Path_Id : Name_Id; - - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Path (Path'First .. Last_Path)); - Path_Id := Name_Find; - - Name_Len := 0; - Add_Str_To_Name_Buffer - (Display_Path - (Display_Path'First .. Last_Display_Path)); - Display_Path_Id := Name_Find; - - Add_To_Or_Remove_From_List - (Path_Id => Path_Id, - Display_Path_Id => Display_Path_Id); - end; + -- links have been resolved if necessary, and Path_Name + -- always ends with a directory separator + Add_To_Or_Remove_From_Source_Dirs + (Path_Id => Path_Name.Name, + Display_Path_Id => Path_Name.Display_Name, + Rank => Rank, + Removed => Removed); end if; end; end if; @@ -5273,21 +5317,9 @@ package body Prj.Nmsc is Err_Vars.Error_Msg_File_1 := File_Name_Type (Object_Dir.Value); - - case Data.Flags.Require_Obj_Dirs is - when Error => - Error_Msg - (Data.Flags, - "object directory { not found", - Project.Location, Project); - when Warning => - Error_Msg - (Data.Flags, - "?object directory { not found", - Project.Location, Project); - when Silent => - null; - end case; + Error_Or_Warning + (Data.Flags, Data.Flags.Require_Obj_Dirs, + "object directory { not found", Project.Location, Project); end if; end if; @@ -5373,7 +5405,7 @@ package body Prj.Nmsc is pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); - if (not Source_Files.Default) + if not Source_Files.Default and then Source_Files.Values = Nil_String then Project.Source_Dirs := Nil_String; @@ -5386,43 +5418,14 @@ package body Prj.Nmsc is end if; elsif Source_Dirs.Default then - -- No Source_Dirs specified: the single source directory is the one -- containing the project file. - String_Element_Table.Append (Data.Tree.String_Elements, - (Value => Name_Id (Project.Directory.Name), - Display_Value => Name_Id (Project.Directory.Display_Name), - Location => No_Location, - Flag => False, - Next => Nil_String, - Index => 0)); - - Project.Source_Dirs := - String_Element_Table.Last (Data.Tree.String_Elements); - - Number_List_Table.Append - (Data.Tree.Number_Lists, - (Number => 1, Next => No_Number_List)); - - Project.Source_Dir_Ranks := - Number_List_Table.Last (Data.Tree.Number_Lists); - - if Current_Verbosity = High then - Write_Attr - ("Default source directory", - Get_Name_String (Project.Directory.Display_Name)); - end if; - - elsif Source_Dirs.Values = Nil_String then - if Project.Qualifier = Standard then - Error_Msg - (Data.Flags, - "a standard project cannot have no source directories", - Source_Dirs.Location, Project); - end if; - - Project.Source_Dirs := Nil_String; + Add_To_Or_Remove_From_Source_Dirs + (Path_Id => Project.Directory.Name, + Display_Path_Id => Project.Directory.Display_Name, + Rank => 1, + Removed => False); else declare @@ -5441,6 +5444,15 @@ package body Prj.Nmsc is (File_Name_Type (Element.Value), Element.Location, Rank); Source_Dir := Element.Next; end loop; + + if Project.Source_Dirs = Nil_String + and then Project.Qualifier = Standard + then + Error_Msg + (Data.Flags, + "a standard project cannot have no source directories", + Source_Dirs.Location, Project); + end if; end; end if; @@ -5608,7 +5620,11 @@ package body Prj.Nmsc is (Name => Source_Name, Location => Location, Source => No_Source, + Listed => True, Found => False); + + else + Name_Loc.Listed := True; end if; Source_Names_Htable.Set @@ -6240,14 +6256,14 @@ package body Prj.Nmsc is ------------------ procedure Find_Sources - (Project : in out Project_Processing_Data; - Data : in out Tree_Processing_Data) + (Project : in out Project_Processing_Data; + Data : in out Tree_Processing_Data) is Sources : constant Variable_Value := Util.Value_Of (Name_Source_Files, - Project.Project.Decl.Attributes, - Data.Tree); + Project.Project.Decl.Attributes, + Data.Tree); Source_List_File : constant Variable_Value := Util.Value_Of @@ -6343,11 +6359,16 @@ package body Prj.Nmsc is (Name => Name, Location => Location, Source => No_Source, + Listed => True, Found => False); - Source_Names_Htable.Set - (Project.Source_Names, Name, Name_Loc); + + else + Name_Loc.Listed := True; end if; + Source_Names_Htable.Set + (Project.Source_Names, Name, Name_Loc); + Current := Element.Next; end loop; @@ -6394,6 +6415,57 @@ package body Prj.Nmsc is Has_Explicit_Sources := False; end if; + -- Remove any exception that is not in the specified list of sources + + if Has_Explicit_Sources then + declare + Source : Source_Id; + Iter : Source_Iterator; + NL : Name_Location; + Again : Boolean; + begin + Iter_Loop : + loop + Again := False; + Iter := For_Each_Source (Data.Tree, Project.Project); + + Source_Loop : + loop + Source := Prj.Element (Iter); + exit Source_Loop when Source = No_Source; + + if Source.Naming_Exception then + NL := Source_Names_Htable.Get + (Project.Source_Names, Source.File); + + if NL /= No_Name_Location and then not NL.Listed then + -- Remove the exception + Source_Names_Htable.Set + (Project.Source_Names, + Source.File, + No_Name_Location); + Remove_Source (Source, No_Source); + + Error_Msg_Name_1 := Name_Id (Source.File); + Error_Msg + (Data.Flags, + "? unknown source file %%", + NL.Location, + Project.Project); + + Again := True; + exit Source_Loop; + end if; + end if; + + Next (Iter); + end loop Source_Loop; + + exit Iter_Loop when not Again; + end loop Iter_Loop; + end; + end if; + Search_Directories (Project, Data => Data, @@ -6404,6 +6476,8 @@ package body Prj.Nmsc is declare Source : Source_Id; Iter : Source_Iterator; + Found : Boolean := False; + Path : Path_Information; begin Iter := For_Each_Source (Data.Tree, Project.Project); @@ -6415,26 +6489,31 @@ package body Prj.Nmsc is and then Source.Path = No_Path_Information then if Source.Unit /= No_Unit_Index then + Found := False; -- For multi-unit source files, source_id gets duplicated -- once for every unit. Only the first source_id got its - -- full path set. So if it isn't set for that first one, - -- the file wasn't found. Otherwise we need to update for - -- units after the first one. + -- full path set. - if Source.Index = 0 - or else Source.Index = 1 - then + if Source.Index /= 0 then + Path := Files_Htable.Get + (Data.File_To_Source, Source.File).Path; + + if Path /= No_Path_Information then + Found := True; + end if; + end if; + + if not Found then Error_Msg_Name_1 := Name_Id (Source.Display_File); Error_Msg_Name_2 := Name_Id (Source.Unit.Name); - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "source file %% for unit %% not found", No_Location, Project.Project); else - Source.Path := Files_Htable.Get - (Data.File_To_Source, Source.File).Path; + Source.Path := Path; if Current_Verbosity = High then if Source.Path /= No_Path_Information then @@ -6442,7 +6521,7 @@ package body Prj.Nmsc is & Get_Name_String (Source.File) & " at" & Source.Index'Img & " to " - & Get_Name_String (Source.Path.Name)); + & Get_Name_String (Path.Name)); end if; end if; end if; @@ -6471,17 +6550,15 @@ package body Prj.Nmsc is while NL /= No_Name_Location loop if not NL.Found then Err_Vars.Error_Msg_File_1 := NL.Name; - if First_Error then - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "source file { not found", NL.Location, Project.Project); First_Error := False; - else - Error_Msg - (Data.Flags, + Error_Or_Warning + (Data.Flags, Data.Flags.Missing_Source_Files, "\source file { not found", NL.Location, Project.Project); end if; @@ -6719,15 +6796,12 @@ package body Prj.Nmsc is Data : in out Tree_Processing_Data; Source_Dir_Rank : Natural; Path : Path_Name_Type; + Display_Path : Path_Name_Type; File_Name : File_Name_Type; Display_File_Name : File_Name_Type; Locally_Removed : Boolean; For_All_Sources : Boolean) is - Canonical_Path : constant Path_Name_Type := - Path_Name_Type - (Canonical_Case_File_Name (Name_Id (Path))); - Name_Loc : Name_Location := Source_Names_Htable.Get (Project.Source_Names, File_Name); @@ -6777,11 +6851,11 @@ package body Prj.Nmsc is Check_Name := True; else - Name_Loc.Source.Path := (Canonical_Path, Path); + Name_Loc.Source.Path := (Path, Display_Path); Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, - Canonical_Path, + Path, Name_Loc.Source); -- Check if this is a subunit @@ -6790,7 +6864,7 @@ package body Prj.Nmsc is and then Name_Loc.Source.Kind = Impl then Src_Ind := Sinput.P.Load_Project_File - (Get_Name_String (Canonical_Path)); + (Get_Name_String (Path)); if Sinput.P.Source_File_Is_Subunit (Src_Ind) then Override_Kind (Name_Loc.Source, Sep); @@ -6842,7 +6916,7 @@ package body Prj.Nmsc is Display_File => Display_File_Name, Unit => Unit, Locally_Removed => Locally_Removed, - Path => (Canonical_Path, Path)); + Path => (Path, Display_Path)); -- If it is a source specified in a list, update the entry in -- the Source_Names table. @@ -6889,32 +6963,36 @@ package body Prj.Nmsc is Num_Nod := Data.Tree.Number_Lists.Table (Src_Dir_Rank); Element := Data.Tree.String_Elements.Table (Source_Dir); - if Element.Value /= No_Name then - Get_Name_String (Element.Display_Value); - - if Current_Verbosity = High then - Write_Str ("Directory: "); - Write_Str (Name_Buffer (1 .. Name_Len)); - Write_Line (Num_Nod.Number'Img); - end if; + -- Use Element.Value in this test, not Display_Value, because we + -- want the symbolic links to be resolved when appropriate. + if Element.Value /= No_Name then declare Source_Directory : constant String := - Name_Buffer (1 .. Name_Len) & - Directory_Separator; + Get_Name_String (Element.Value) + & Directory_Separator; Dir_Last : constant Natural := - Compute_Directory_Last - (Source_Directory); + Compute_Directory_Last (Source_Directory); + + Display_Source_Directory : constant String := + Get_Name_String + (Element.Display_Value) + & Directory_Separator; + -- Display_Source_Directory is to allow us to open a UTF-8 + -- encoded directory on Windows. begin if Current_Verbosity = High then - Write_Attr ("Source_Dir", Source_Directory); + Write_Attr + ("Source_Dir", + Source_Directory (Source_Directory'First .. Dir_Last)); + Write_Line (Num_Nod.Number'Img); end if; -- We look to every entry in the source directory - Open (Dir, Source_Directory); + Open (Dir, Display_Source_Directory); loop Read (Dir, Name, Last); @@ -6929,7 +7007,7 @@ package body Prj.Nmsc is if not Opt.Follow_Links_For_Files or else Is_Regular_File - (Source_Directory & Name (1 .. Last)) + (Display_Source_Directory & Name (1 .. Last)) then if Current_Verbosity = High then Write_Str (" Checking "); @@ -6959,17 +7037,24 @@ package body Prj.Nmsc is Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True); - -- Case_Sensitive set True (no folding) - Path : Path_Name_Type; - FF : File_Found := Excluded_Sources_Htable.Get - (Project.Excluded, File_Name); + Path : Path_Name_Type; + FF : File_Found := + Excluded_Sources_Htable.Get + (Project.Excluded, File_Name); To_Remove : Boolean := False; begin Name_Len := Path_Name'Length; Name_Buffer (1 .. Name_Len) := Path_Name; - Path := Name_Find; + + if Osint.File_Names_Case_Sensitive then + Path := Name_Find; + else + Canonical_Case_File_Name + (Name_Buffer (1 .. Name_Len)); + Path := Name_Find; + end if; if FF /= No_File_Found then if not FF.Found then @@ -6979,7 +7064,8 @@ package body Prj.Nmsc is if Current_Verbosity = High then Write_Str (" excluded source """); - Write_Str (Get_Name_String (File_Name)); + Write_Str + (Get_Name_String (Display_File_Name)); Write_Line (""""); end if; @@ -6993,11 +7079,20 @@ package body Prj.Nmsc is end if; end if; + -- Preserve the user's original casing and use of + -- links. The display_value (a directory) already + -- ends with a directory separator by construction, + -- so no need to add one. + + Get_Name_String (Element.Display_Value); + Get_Name_String_And_Append (Display_File_Name); + Check_File (Project => Project, Source_Dir_Rank => Num_Nod.Number, Data => Data, Path => Path, + Display_Path => Name_Find, File_Name => File_Name, Locally_Removed => To_Remove, Display_File_Name => Display_File_Name, @@ -7064,8 +7159,9 @@ package body Prj.Nmsc is K => Source.File, E => Name_Location' (Name => Source.File, - Location => No_Location, + Location => Source.Location, Source => Source, + Listed => False, Found => False)); -- If this is an Ada exception, record in table Unit_Exceptions @@ -7437,7 +7533,7 @@ package body Prj.Nmsc is while Current /= Nil_String loop Element := In_Tree.String_Elements.Table (Current); Write_Str (" "); - Write_Line (Get_Name_String (Element.Value)); + Write_Line (Get_Name_String (Element.Display_Value)); Current := Element.Next; end loop; @@ -7483,6 +7579,7 @@ package body Prj.Nmsc is -- Start of processing for Process_Naming_Scheme begin + Lib_Data_Table.Init; Initialize (Data, Tree => Tree, Flags => Flags); Check_All_Projects (Root_Project, Data, Imported_First => True); Free (Data); diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index c733f38365c..b8abe571bc4 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -36,12 +36,11 @@ with Sinput.P; use Sinput.P; with Snames; with Table; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Exceptions; use Ada.Exceptions; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Exceptions; use Ada.Exceptions; with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System.HTable; use System.HTable; +with GNAT.HTable; use GNAT.HTable; package body Prj.Part is @@ -98,7 +97,7 @@ package body Prj.Part is -- limited imported projects when there is a circularity with at least -- one limited imported project file. - package Virtual_Hash is new System.HTable.Simple_HTable + package Virtual_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Node_Id, No_Element => Empty_Node, @@ -108,7 +107,7 @@ package body Prj.Part is -- Hash table to store the node id of the project for which a virtual -- extending project need to be created. - package Processed_Hash is new System.HTable.Simple_HTable + package Processed_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, @@ -119,7 +118,7 @@ package body Prj.Part is -- need to have a virtual extending project, to avoid processing the same -- project twice. - package Projects_Paths is new System.HTable.Simple_HTable + package Projects_Paths is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Path_Name_Type, No_Element => No_Path, diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 1120d5b9e4e..5859a8afe82 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -87,15 +87,15 @@ package body Prj.Proc is -- based languages) procedure Copy_Package_Declarations - (From : Declarations; - To : in out Declarations; - New_Loc : Source_Ptr; - Naming_Restricted : Boolean; - In_Tree : Project_Tree_Ref); + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + In_Tree : Project_Tree_Ref); -- Copy a package declaration From to To for a renamed package. Change the - -- locations of all the attributes to New_Loc. When Naming_Restricted is - -- True, do not copy attributes Body, Spec, Implementation and - -- Specification. + -- locations of all the attributes to New_Loc. When Restricted is + -- True, do not copy attributes Body, Spec, Implementation, Specification + -- and Linker_Options. function Expression (Project : Project_Id; @@ -314,11 +314,11 @@ package body Prj.Proc is ------------------------------- procedure Copy_Package_Declarations - (From : Declarations; - To : in out Declarations; - New_Loc : Source_Ptr; - Naming_Restricted : Boolean; - In_Tree : Project_Tree_Ref) + (From : Declarations; + To : in out Declarations; + New_Loc : Source_Ptr; + Restricted : Boolean; + In_Tree : Project_Tree_Ref) is V1 : Variable_Id; V2 : Variable_Id := No_Variable; @@ -346,6 +346,12 @@ package body Prj.Proc is Var := In_Tree.Variable_Elements.Table (V1); V1 := Var.Next; + -- Do not copy the value of attribute inker_Options if Restricted + + if Restricted and then Var.Name = Snames.Name_Linker_Options then + Var.Value.Values := Nil_String; + end if; + -- Remove the Next component Var.Next := No_Variable; @@ -376,16 +382,16 @@ package body Prj.Proc is Arr := In_Tree.Arrays.Table (A1); A1 := Arr.Next; - if not Naming_Restricted or else - (Arr.Name /= Snames.Name_Body - and then Arr.Name /= Snames.Name_Spec - and then Arr.Name /= Snames.Name_Implementation - and then Arr.Name /= Snames.Name_Specification) + if not Restricted + or else + (Arr.Name /= Snames.Name_Body and then + Arr.Name /= Snames.Name_Spec and then + Arr.Name /= Snames.Name_Implementation and then + Arr.Name /= Snames.Name_Specification) then -- Remove the Next component Arr.Next := No_Array; - Array_Table.Increment_Last (In_Tree.Arrays); -- Create new Array declaration @@ -1255,9 +1261,101 @@ package body Prj.Proc is Pkg : Package_Id; Item : Project_Node_Id) is + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id); + -- Check whether Value is valid for this typed variable declaration. If + -- it is an error, the behavior depends on the flags: either an error is + -- reported, or a warning, or nothing. In the last two cases, the value + -- of the variable is set to a valid value, replacing Value. + + --------------------------------- + -- Check_Or_Set_Typed_Variable -- + --------------------------------- + + procedure Check_Or_Set_Typed_Variable + (Value : in out Variable_Value; + Declaration : Project_Node_Id) + is + Loc : constant Source_Ptr := + Location_Of (Declaration, From_Project_Node_Tree); + + Reset_Value : Boolean := False; + Current_String : Project_Node_Id; + + begin + -- Report an error for an empty string + + if Value.Value = Empty_String then + Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree); + + case Flags.Allow_Invalid_External is + when Error => + Error_Msg (Flags, "no value defined for %%", Loc, Project); + when Warning => + Reset_Value := True; + Error_Msg (Flags, "?no value defined for %%", Loc, Project); + when Silent => + Reset_Value := True; + end case; + + else + -- Loop through all the valid strings for the + -- string type and compare to the string value. + + Current_String := + First_Literal_String + (String_Type_Of (Declaration, From_Project_Node_Tree), + From_Project_Node_Tree); + while Present (Current_String) + and then String_Value_Of + (Current_String, From_Project_Node_Tree) /= Value.Value + loop + Current_String := + Next_Literal_String (Current_String, From_Project_Node_Tree); + end loop; + + -- Report error if string value is not one for the string type + + if No (Current_String) then + Error_Msg_Name_1 := Value.Value; + Error_Msg_Name_2 := + Name_Of (Declaration, From_Project_Node_Tree); + + case Flags.Allow_Invalid_External is + when Error => + Error_Msg + (Flags, "value %% is illegal for typed string %%", + Loc, Project); + when Warning => + Error_Msg + (Flags, "?value %% is illegal for typed string %%", + Loc, Project); + Reset_Value := True; + when Silent => + Reset_Value := True; + end case; + end if; + end if; + + if Reset_Value then + Current_String := + First_Literal_String + (String_Type_Of (Declaration, From_Project_Node_Tree), + From_Project_Node_Tree); + + Value.Value := String_Value_Of + (Current_String, From_Project_Node_Tree); + end if; + end Check_Or_Set_Typed_Variable; + + -- Local variables + Current_Declarative_Item : Project_Node_Id; Current_Item : Project_Node_Id; + -- Start of processing for Process_Declarative_Items + begin -- Loop through declarative items @@ -1353,15 +1451,15 @@ package body Prj.Proc is -- renaming declaration. Copy_Package_Declarations - (From => + (From => In_Tree.Packages.Table (Renamed_Package).Decl, - To => + To => In_Tree.Packages.Table (New_Pkg).Decl, - New_Loc => + New_Loc => Location_Of (Current_Item, From_Project_Node_Tree), - Naming_Restricted => False, - In_Tree => In_Tree); + Restricted => False, + In_Tree => In_Tree); end; -- Standard package declaration, not renaming @@ -1677,7 +1775,7 @@ package body Prj.Proc is else declare - New_Value : constant Variable_Value := + New_Value : Variable_Value := Expression (Project => Project, In_Tree => In_Tree, @@ -1713,59 +1811,9 @@ package body Prj.Proc is if Kind_Of (Current_Item, From_Project_Node_Tree) = N_Typed_Variable_Declaration then - -- Report an error for an empty string - - if New_Value.Value = Empty_String then - Error_Msg_Name_1 := - Name_Of (Current_Item, From_Project_Node_Tree); - Error_Msg - (Flags, - "no value defined for %%", - Location_Of - (Current_Item, From_Project_Node_Tree), - Project); - - else - declare - Current_String : Project_Node_Id; - - begin - -- Loop through all the valid strings for the - -- string type and compare to the string value. - - Current_String := - First_Literal_String - (String_Type_Of (Current_Item, - From_Project_Node_Tree), - From_Project_Node_Tree); - while Present (Current_String) - and then - String_Value_Of - (Current_String, From_Project_Node_Tree) /= - New_Value.Value - loop - Current_String := - Next_Literal_String - (Current_String, From_Project_Node_Tree); - end loop; - - -- Report an error if the string value is not - -- one for the string type. - - if No (Current_String) then - Error_Msg_Name_1 := New_Value.Value; - Error_Msg_Name_2 := - Name_Of - (Current_Item, From_Project_Node_Tree); - Error_Msg - (Flags, - "value %% is illegal for typed string %%", - Location_Of - (Current_Item, From_Project_Node_Tree), - Project); - end if; - end; - end if; + Check_Or_Set_Typed_Variable + (Value => New_Value, + Declaration => Current_Item); end if; -- Comment here ??? @@ -2579,13 +2627,12 @@ package body Prj.Proc is Next => Project.Decl.Packages); Project.Decl.Packages := Current_Pkg; Copy_Package_Declarations - (From => Element.Decl, - To => + (From => Element.Decl, + To => In_Tree.Packages.Table (Current_Pkg).Decl, - New_Loc => No_Location, - Naming_Restricted => - Element.Name = Snames.Name_Naming, - In_Tree => In_Tree); + New_Loc => No_Location, + Restricted => True, + In_Tree => In_Tree); end if; Extended_Pkg := Element.Next; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 0bae53c23fc..be02a417014 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -34,10 +34,9 @@ with Uintp; use Uintp; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Unchecked_Deallocation; +with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System.Case_Util; use System.Case_Util; -with System.HTable; +with GNAT.HTable; package body Prj is @@ -568,7 +567,7 @@ package body Prj is -- Hash -- ---------- - function Hash is new System.HTable.Hash (Header_Num => Header_Num); + function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); -- Used in implementation of other functions Hash below function Hash (Name : File_Name_Type) return Header_Num is @@ -1226,11 +1225,13 @@ package body Prj is function Create_Flags (Report_Error : Error_Handler; When_No_Sources : Error_Warning; - Require_Sources_Other_Lang : Boolean := True; - Allow_Duplicate_Basenames : Boolean := True; - Compiler_Driver_Mandatory : Boolean := False; - Error_On_Unknown_Language : Boolean := True; - Require_Obj_Dirs : Error_Warning := Error) + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True; + Require_Obj_Dirs : Error_Warning := Error; + Allow_Invalid_External : Error_Warning := Error; + Missing_Source_Files : Error_Warning := Error) return Processing_Flags is begin @@ -1241,7 +1242,9 @@ package body Prj is Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, Error_On_Unknown_Language => Error_On_Unknown_Language, Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, - Require_Obj_Dirs => Require_Obj_Dirs); + Require_Obj_Dirs => Require_Obj_Dirs, + Allow_Invalid_External => Allow_Invalid_External, + Missing_Source_Files => Missing_Source_Files); end Create_Flags; ------------ diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 353138d2daf..a6a79646a53 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -667,6 +667,10 @@ package Prj is Project : Project_Id := No_Project; -- Project of the source + Location : Source_Ptr := No_Location; + -- Location in the project file of the declaration of the source in + -- package Naming. + Source_Dir_Rank : Natural := 0; -- The rank of the source directory in list declared with attribute -- Source_Dirs. Two source files with the same name cannot appears in @@ -768,6 +772,7 @@ package Prj is No_Source_Data : constant Source_Data := (Project => No_Project, + Location => No_Location, Source_Dir_Rank => 0, Language => No_Language_Index, In_Interfaces => True, @@ -894,6 +899,7 @@ package Prj is type Response_File_Format is (None, GNU, + GCC, Object_List, Option_List); -- The format of the different response files @@ -1448,11 +1454,13 @@ package Prj is function Create_Flags (Report_Error : Error_Handler; When_No_Sources : Error_Warning; - Require_Sources_Other_Lang : Boolean := True; - Allow_Duplicate_Basenames : Boolean := True; - Compiler_Driver_Mandatory : Boolean := False; - Error_On_Unknown_Language : Boolean := True; - Require_Obj_Dirs : Error_Warning := Error) + Require_Sources_Other_Lang : Boolean := True; + Allow_Duplicate_Basenames : Boolean := True; + Compiler_Driver_Mandatory : Boolean := False; + Error_On_Unknown_Language : Boolean := True; + Require_Obj_Dirs : Error_Warning := Error; + Allow_Invalid_External : Error_Warning := Error; + Missing_Source_Files : Error_Warning := Error) return Processing_Flags; -- Function used to create Processing_Flags structure -- @@ -1481,6 +1489,15 @@ package Prj is -- If Require_Obj_Dirs is true, then all object directories must exist -- (possibly after they have been created automatically if the appropriate -- switches were specified), or an error is raised. + -- + -- If Allow_Invalid_External is Silent, then no error is reported when an + -- invalid value is used for an external variable (and it doesn't match its + -- type). Instead, the first possible value is used. + -- + -- Missing_Source_Files indicates whether it is an error or a warning that + -- a source file mentioned in the Source_Files attributes is not actually + -- found in the source directories. This also impacts errors for missing + -- source directories. Gprbuild_Flags : constant Processing_Flags; Gprclean_Flags : constant Processing_Flags; @@ -1510,6 +1527,10 @@ package Prj is -- another program running on the same machine has recreated it. -- Does nothing if Debug.Debug_Flag_N is set + Virtual_Prefix : constant String := "v$"; + -- The prefix for virtual extending projects. Because of the '$', which is + -- normally forbidden for project names, there cannot be any name clash. + private All_Packages : constant String_List_Access := null; @@ -1524,10 +1545,6 @@ private Location => No_Location, Default => False); - Virtual_Prefix : constant String := "v$"; - -- The prefix for virtual extending projects. Because of the '$', which is - -- normally forbidden for project names, there cannot be any name clash. - type Source_Iterator is record In_Tree : Project_Tree_Ref; @@ -1589,6 +1606,8 @@ private Compiler_Driver_Mandatory : Boolean; Error_On_Unknown_Language : Boolean; Require_Obj_Dirs : Error_Warning; + Allow_Invalid_External : Error_Warning; + Missing_Source_Files : Error_Warning; end record; Gprbuild_Flags : constant Processing_Flags := @@ -1598,7 +1617,9 @@ private Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, - Require_Obj_Dirs => Error); + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); Gprclean_Flags : constant Processing_Flags := (Report_Error => null, @@ -1607,7 +1628,9 @@ private Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, - Require_Obj_Dirs => Warning); + Require_Obj_Dirs => Warning, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); Gnatmake_Flags : constant Processing_Flags := (Report_Error => null, @@ -1616,6 +1639,8 @@ private Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => False, Error_On_Unknown_Language => False, - Require_Obj_Dirs => Error); + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error); end Prj; diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi new file mode 100644 index 00000000000..20fb19c8ee1 --- /dev/null +++ b/gcc/ada/projects.texi @@ -0,0 +1,3889 @@ +@set gprconfig GPRconfig + +@c ------ projects.texi +@c This file is shared between the GNAT user's guide and gprbuild. It is not +@c compilable on its own, you should instead compile the other two manuals. +@c For that reason, there is no toplevel @menu + +@c --------------------------------------------- +@node GNAT Project Manager +@chapter GNAT Project Manager +@c --------------------------------------------- + +@noindent +@menu +* Introduction:: +* Building With Projects:: +* Organizing Projects into Subsystems:: +* Scenarios in Projects:: +* Library Projects:: +* Project Extension:: +* Project File Reference:: +@end menu + +@c --------------------------------------------- +@node Introduction +@section Introduction +@c --------------------------------------------- + +@noindent +This chapter describes GNAT's @emph{Project Manager}, a facility that allows +you to manage complex builds involving a number of source files, directories, +and options for different system configurations. In particular, +project files allow you to specify: + +@itemize @bullet +@item The directory or set of directories containing the source files, and/or the + names of the specific source files themselves +@item The directory in which the compiler's output + (@file{ALI} files, object files, tree files, etc.) is to be placed +@item The directory in which the executable programs are to be placed +@item Switch settings for any of the project-enabled tools; + you can apply these settings either globally or to individual compilation units. +@item The source files containing the main subprogram(s) to be built +@item The source programming language(s) +@item Source file naming conventions; you can specify these either globally or for + individual compilation units (@pxref{Naming Schemes}). +@item Change any of the above settings depending on external values, thus enabling + the reuse of the projects in various @b{scenarios} (@pxref{Scenarios + in Projects}). +@item Automatically build libraries as part of the build process + (@pxref{Library Projects}). + +@end itemize + +@noindent +Project files are written in a syntax close to that of Ada, using familiar +notions such as packages, context clauses, declarations, default values, +assignments, and inheritance (@pxref{Project File Reference}). + +Project files can be built hierarchically from other project files, simplifying +complex system integration and project reuse (@pxref{Organizing Projects into +Subsystems}). + +@itemize @bullet +@item One project can import other projects containing needed source files. + More generally, the Project Manager lets you structure large development + efforts into hierarchical subsystems, where build decisions are delegated + to the subsystem level, and thus different compilation environments + (switch settings) used for different subsystems. +@item You can organize GNAT projects in a hierarchy: a child project + can extend a parent project, inheriting the parent's source files and + optionally overriding any of them with alternative versions + (@pxref{Project Extension}). + +@end itemize + +@noindent +Several tools support project files, generally in addition to specifying +the information on the command line itself). They share common switches +to control the loading of the project (in particular +@option{^-P^/PROJECT_FILE=^@emph{projectfile}} and +@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}}). +@xref{Switches Related to Project Files}. + +The Project Manager supports a wide range of development strategies, +for systems of all sizes. Here are some typical practices that are +easily handled: + +@itemize @bullet +@item Using a common set of source files and generating object files in different + directories via different switch settings. It can be used for instance, for + generating separate sets of object files for debugging and for production. +@item Using a mostly-shared set of source files with different versions of + some units or subunits. It can be used for instance, for grouping and hiding +@end itemize + +@noindent +all OS dependencies in a small number of implementation units. + +Project files can be used to achieve some of the effects of a source +versioning system (for example, defining separate projects for +the different sets of sources that comprise different releases) but the +Project Manager is independent of any source configuration management tool +that might be used by the developers. + +The various sections below introduce the different concepts related to +projects. Each section starts with examples and use cases, and then goes into +the details of related project file capabilities. + +@c --------------------------------------------- +@node Building With Projects +@section Building With Projects +@c --------------------------------------------- + +@noindent +In its simplest form, a unique project is used to build a single executable. +This section concentrates on such a simple setup. Later sections will extend +this basic model to more complex setups. + +The following concepts are the foundation of project files, and will be further +detailed later in this documentation. They are summarized here as a reference. + +@table @asis +@item @b{Project file}: + A text file using an Ada-like syntax, generally using the @file{.gpr} + extension. It defines build-related characteristics of an application. + The characteristics include the list of sources, the location of those + sources, the location for the generated object files, the name of + the main program, and the options for the various tools involved in the + build process. + +@item @b{Project attribute}: + A specific project characteristic is defined by an attribute clause. Its + value is a string or a sequence of strings. All settings in a project + are defined through a list of predefined attributes with precise + semantics. @xref{Attributes}. + +@item @b{Package in a project}: + Global attributes are defined at the top level of a project. + Attributes affecting specific tools are grouped in a + package whose name is related to tool's function. The most common + packages are @code{Builder}, @code{Compiler}, @code{Binder}, + and @code{Linker}. @xref{Packages}. + +@item @b{Project variables}: + In addition to attributes, a project can use variables to store intermediate + values and avoid duplication in complex expressions. It can be initialized + with a value coming from the environment. + A frequent use of variables is to define scenarios. + @xref{External Values}, @xref{Scenarios in Projects}, and @xref{Variables}. + +@item @b{Source files} and @b{source directories}: + A source file is associated with a language through a naming convention. For + instance, @code{foo.c} is typically the name of a C source file; + @code{bar.ads} or @code{bar.1.ada} are two common naming conventions for a + file containing an Ada spec. A compilation unit is often composed of a main + source file and potentially several auxiliary ones, such as header files in C. + The naming conventions can be user defined @xref{Naming Schemes}, and will + drive the builder to call the appropriate compiler for the given source file. + Source files are searched for in the source directories associated with the + project through the @b{Source_Dirs} attribute. By default, all the files (in + these source directories) following the naming conventions associated with the + declared languages are considered to be part of the project. It is also + possible to limit the list of source files using the @b{Source_Files} or + @b{Source_List_File} attributes. Note that those last two attributes only + accept basenames with no directory information. + +@item @b{Object files} and @b{object directory}: + An object file is an intermediate file produced by the compiler from a + compilation unit. It is used by post-compilation tools to produce + final executables or libraries. Object files produced in the context of + a given project are stored in a single directory that can be specified by the + @b{Object_Dir} attribute. In order to store objects in + two or more object directories, the system must be split into + distinct subsystems with their own project file. + +@end table + +The following subsections introduce gradually all the attributes of interest +for simple build needs. Here is the simple setup that will be used in the +following examples. + +The Ada source files @file{pack.ads}, @file{pack.adb}, and @file{proc.adb} are in +the @file{common/} directory. The file @file{proc.adb} contains an Ada main +subprogram @code{Proc} that @code{with}s package @code{Pack}. We want to compile +these source files with the switch @option{-O2}, and put the resulting files in +the directory @file{obj/}. + +@smallexample +@group +^common/^[COMMON]^ + pack.ads + pack.adb + proc.adb +@end group +@group +^common/release/^[COMMON.RELEASE]^ + proc.ali, proc.o pack.ali, pack.o +@end group +@end smallexample + +@noindent +Our project is to be called @emph{Build}. The name of the +file is the name of the project (case-insensitive) with the +@file{.gpr} extension, therefore the project file name is @file{build.gpr}. This +is not mandatory, but a warning is issued when this convention is not followed. + +This is a very simple example, and as stated above, a single project +file is enough for it. We will thus create a new file, that for now +should contain the following code: + +@smallexample +@b{project} Build @b{is} +@b{end} Build; +@end smallexample + +@menu +* Source Files and Directories:: +* Object and Exec Directory:: +* Main Subprograms:: +* Tools Options in Project Files:: +* Compiling with Project Files:: +* Executable File Names:: +* Avoid Duplication With Variables:: +* Naming Schemes:: +@end menu + +@c --------------------------------------------- +@node Source Files and Directories +@subsection Source Files and Directories +@c --------------------------------------------- + +@noindent +When you create a new project, the first thing to describe is how to find the +corresponding source files. This is the only settings that are needed by all +the tools that will use this project (builder, compiler, binder and linker for +the compilation, IDEs to edit the source files,@dots{}). + +@cindex Source directories +First step is to declare the source directories, which are the directories +to be searched to find source files. In the case of the example, +the @file{common} directory is the only source directory. + +@cindex @code{Source_Dirs} +There are several ways of defining source directories: + +@itemize @bullet +@item When the attribute @b{Source_Dirs} is not used, a project contains a + single source directory which is the one where the project file itself + resides. In our example, if @file{build.gpr} is placed in the @file{common} + directory, the project has the needed implicit source directory. + +@item The attribute @b{Source_Dirs} can be set to a list of path names, one + for each of the source directories. Such paths can either be absolute + names (for instance @file{"/usr/local/common/"} on UNIX), or relative to the + directory in which the project file resides (for instance "." if + @file{build.gpr} is inside @file{common/}, or "common" if it is one level up). + Each of the source directories must exist and be readable. + +@cindex portability + The syntax for directories is platform specific. For portability, however, + the project manager will always properly translate UNIX-like path names to + the native format of specific platform. For instance, when the same project + file is to be used both on Unix and Windows, "/" should be used as the + directory separator rather than "\". + +@item The attribute @b{Source_Dirs} can automatically include subdirectories + using a special syntax inspired by some UNIX shells. If any of the path in + the list ends with @emph{"/**"}, then that path and all its subdirectories + (recursively) are included in the list of source directories. For instance, + @file{./**} represent the complete directory tree rooted at ".". +@cindex Source directories, recursive + +@cindex @code{Excluded_Source_Dirs} + When using that construct, it can sometimes be convenient to also use the + attribute @b{Excluded_Source_Dirs}, which is also a list of paths. Each entry + specifies a directory whose immediate content, not including subdirs, is to + be excluded. It is also possible to exclude a complete directory subtree + using the "/**" notation. + +@end itemize + +@noindent +When applied to the simple example, and because we generally prefer to have +the project file at the toplevel directory rather than mixed with the sources, +we will create the following file + +@smallexample + build.gpr + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); -- <<<< + @b{end} Build; +@end smallexample + +@noindent +Once source directories have been specified, one may need to indicate +source files of interest. By default, all source files present in the source +directories are considered by the project manager. When this is not desired, +it is possible to specify the list of sources to consider explicitly. +In such a case, only source file base names are indicated and not +their absolute or relative path names. The project manager is in charge of +locating the specified source files in the specified source directories. + +@itemize @bullet +@item By default, the project manager search for all source files of all + specified languages in all the source directories. + + Since the project manager was initially developed for Ada environments, the + default language is usually Ada and the above project file is complete: it + defines without ambiguity the sources composing the project: that is to say, + all the sources in subdirectory "common" for the default language (Ada) using + the default naming convention. + +@cindex @code{Languages} + However, when compiling a multi-language application, or a pure C + application, the project manager must be told which languages are of + interest, which is done by setting the @b{Languages} attribute to a list of + strings, each of which is the name of a language. Tools like + @command{gnatmake} only know about Ada, while other tools like + @command{gprbuild} know about many more languages such as C, C++, Fortran, + assembly and others can be added dynamically. + +@cindex Naming scheme + Even when using only Ada, the default naming might not be suitable. Indeed, + how does the project manager recognizes an "Ada file" from any other + file? Project files can describe the naming scheme used for source files, + and override the default (@pxref{Naming Schemes}). The default is the + standard GNAT extension (@file{.adb} for bodies and @file{.ads} for + specs), which is what is used in our example, explaining why no naming scheme + is explicitly specified. + @xref{Naming Schemes}. + +@item @code{Source Files} + @cindex @code{Source_Files} + In some cases, source directories might contain files that should not be + included in a project. One can specify the explicit list of file names to + be considered through the @b{Source_Files} attribute. + When this attribute is defined, instead of looking at every file in the + source directories, the project manager takes only those names into + consideration reports errors if they cannot be found in the source + directories or does not correspond to the naming scheme. + +@item For various reasons, it is sometimes useful to have a project with no + sources (most of the time because the attributes defined in the project + file will be reused in other projects, as explained in @pxref{Organizing + Projects into Subsystems}. To do this, the attribute + @emph{Source_Files} is set to the empty list, i.e. @code{()}. Alternatively, + @emph{Source_Dirs} can be set to the empty list, with the same + result. + +@item @code{Source_List_File} +@cindex @code{Source_List_File} + If there is a great number of files, it might be more convenient to use + the attribute @b{Source_List_File}, which specifies the full path of a file. + This file must contain a list of source file names (one per line, no + directory information) that are searched as if they had been defined + through @emph{Source_Files}. Such a file can easily be created through + external tools. + + A warning is issued if both attributes @code{Source_Files} and + @code{Source_List_File} are given explicit values. In this case, the + attribute @code{Source_Files} prevails. + +@item @code{Excluded_Source_Files} +@cindex @code{Excluded_Source_Files} +@cindex @code{Locally_Removed_Files} +@cindex @code{Excluded_Source_List_File} + Specifying an explicit list of files is not always convenient.It might be + more convenient to use the default search rules with specific exceptions. + This can be done thanks to the attribute @b{Excluded_Source_Files} + (or its synonym @b{Locally_Removed_Files}). + Its value is the list of file names that should not be taken into account. + This attribute is often used when extending a project, @xref{Project + Extension}. A similar attribute @b{Excluded_Source_List_File} plays the same + role but takes the name of file containing file names similarly to + @code{Source_List_File}. + +@end itemize + +@noindent +In most simple cases, such as the above example, the default source file search +behavior provides the expected result, and we do not need to add anything after +setting @code{Source_Dirs}. The project manager automatically finds +@file{pack.ads}, @file{pack.adb} and @file{proc.adb} as source files of the +project. + +Note that it is considered an error for a project file to have no sources +attached to it unless explicitly declared as mentionend above. + +If the order of the source directories is known statically, that is if +@code{"/**"} is not used in the string list @code{Source_Dirs}, then there may +be several files with the same source file name sitting in different +directories of the project. In this case, only the file in the first directory +is considered as a source of the project and the others are hidden. If +@code{"/**"} is not used in the string list @code{Source_Dirs}, it is an error +to have several files with the same source file name in the same directory +@code{"/**"} subtree, since there would be an ambiguity as to which one should +be used. However, two files with the same source file name may in two single +directories or directory subtrees. In this case, the one in the first directory +or directory subtree is a source of the project. + +@c --------------------------------------------- +@node Object and Exec Directory +@subsection Object and Exec Directory +@c --------------------------------------------- + +@noindent +The next step when writing a project is to indicate where the compiler should +put the object files. In fact, the compiler and other tools might create +several different kind of files (for GNAT, there is the object file and the ALI +file for instance). One of the important concepts in projects is that most +tools may consider source directories as read-only and do not attempt to create +new or temporary files there. Instead, all files are created in the object +directory. It is of course not true for project-aware IDEs, whose purpose it is +to create the source files. + +@cindex @code{Object_Dir} +The object directory is specified through the @b{Object_Dir} attribute. +Its value is the path to the object directory, either absolute or +relative to the directory containing the project file. This +directory must already exist and be readable and writable, although +some tools have a switch to create the directory if needed (See +the switch @code{-p} for @command{gnatmake} and @command{gprbuild}). + +If the attribute @code{Object_Dir} is not specified, it defaults to +the project directory, that is the directory containing the project file. + +For our example, we can specify the object dir in this way: + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; -- <<<< + @b{end} Build; +@end smallexample + +@noindent +As mentioned earlier, there is a single object directory per project. As a +result, if you have an existing system where the object files are spread in +several directories, you can either move all of them into the same directory if +you want to build it with a single project file, or study the section on +subsystems (@pxref{Organizing Projects into Subsystems}) to see how each +separate object directory can be associated with one of the subsystem +constituting the application. + +When the @command{linker} is called, it usually creates an executable. By +default, this executable is placed in the object directory of the project. It +might be convenient to store it in its own directory. + +@cindex @code{Exec_Dir} +This can be done through the @code{Exec_Dir} attribute, which, like +@emph{Object_Dir} contains a single absolute or relative path and must point to +an existing and writable directory, unless you ask the tool to create it on +your behalf. When not specified, It defaults to the object directory and +therefore to the project file's directory if neither @emph{Object_Dir} nor +@emph{Exec_Dir} was specified. + +In the case of the example, let's place the executable in the root +of the hierarchy, ie the same directory as @file{build.gpr}. Hence +the project file is now + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; -- <<<< + @b{end} Build; +@end smallexample + +@c --------------------------------------------- +@node Main Subprograms +@subsection Main Subprograms +@c --------------------------------------------- + +@noindent +In the previous section, executables were mentioned. The project manager needs +to be taught what they are. In a project file, an executable is indicated by +pointing to source file of the main subprogram. In C this is the file that +contains the @code{main} function, and in Ada the file that contains the main +unit. + +There can be any number of such main files within a given project, and thus +several executables can be built in the context of a single project file. Of +course, one given executable might not (and in fact will not) need all the +source files referenced by the project. As opposed to other build environments +such as @command{makefile}, one does not need to specify the list of +dependencies of each executable, the project-aware builders knows enough of the +semantics of the languages to build ands link only the necessary elements. + +@cindex @code{Main} +The list of main files is specified via the @b{Main} attribute. It contains +a list of file names (no directories). If a project defines this +attribute, it is not necessary to identify main files on the +command line when invoking a builder, and editors like +@command{GPS} will be able to create extra menus to spawn or debug the +corresponding executables. + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; + @b{for} Main @b{use} ("proc.adb"); -- <<<< + @b{end} Build; +@end smallexample + +@noindent +If this attribute is defined in the project, then spawning the builder +with a command such as + +@smallexample + gnatmake ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +automatically builds all the executables corresponding to the files +listed in the @emph{Main} attribute. It is possible to specify one +or more executables on the command line to build a subset of them. + +@c --------------------------------------------- +@node Tools Options in Project Files +@subsection Tools Options in Project Files +@c --------------------------------------------- + +@noindent +We now have a project file that fully describes our environment, and can be +used to build the application with a simple @command{gnatmake} command as seen +in the previous section. In fact, the empty project we showed immediately at +the beginning (with no attribute at all) could already fullfill that need if it +was put in the @file{common} directory. + +Of course, we always want more control. This section will show you how to +specify the compilation switches that the various tools involved in the +building of the executable should use. + +@cindex command line length +Since source names and locations are described into the project file, it is not +necessary to use switches on the command line for this purpose (switches such +as -I for gcc). This removes a major source of command line length overflow. +Clearly, the builders will have to communicate this information one way or +another to the underlying compilers and tools they call but they usually use +response files for this and thus should not be subject to command line +overflows. + +Several tools are participating to the creation of an executable: the compiler +produces object files from the source files; the binder (in the Ada case) +creates an source file that takes care, among other things, of elaboration +issues and global variables initialization; and the linker gathers everything +into a single executable that users can execute. All these tools are known by +the project manager and will be called with user defined switches from the +project files. However, we need to introduce a new project file concept to +express which switches to be used for any of the tools involved in the build. + +@cindex project file packages +A project file is subdivided into zero or more @b{packages}, each of which +contains the attributes specific to one tool (or one set of tools). Project +files use an Ada-like syntax for packages. Package names permitted in project +files are restricted to a predefined set (@pxref{Packages}), and the contents +of packages are limited to a small set of constructs and attributes +(@pxref{Attributes}). + +Our example project file can be extended with the following empty packages. At +this stage, they could all be omitted since they are empty, but they show which +packages would be involved in the build process. + +@smallexample + @b{project} Build @b{is} + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Exec_Dir @b{use} "."; + @b{for} Main @b{use} ("proc.adb"); + @b{end} Build; + + @b{package} Builder @b{is} --<<< for gnatmake and gprbuild + @b{end} Builder; + + @b{package} Compiler @b{is} --<<< for the compiler + @b{end} Builder; + + @b{package} Binder @b{is} --<<< for the binder + @b{end} Builder; + + @b{package} Linker @b{is} --<<< for the linker + @b{end} Builder; +@end smallexample + +@noindent +Let's first examine the compiler switches. As stated in the initial description +of the example, we want to compile all files with @option{-O2}. This is a +compiler switch, although it is usual, on the command line, to pass it to the +builder which then passes it to the compiler. It is recommended to use directly +the right package, which will make the setup easier to understand for other +people. + +Several attributes can be used to specify the switches: + +@table @asis +@item @b{Default_Switches}: +@cindex @code{Default_Switches} + This is the first mention in this manual of an @b{indexed attribute}. When + this attribute is defined, one must supply an @emph{index} in the form of a + literal string. + In the case of @emph{Default_Switches}, the index is the name of the + language to which the switches apply (since a different compiler will + likely be used for each language, and each compiler has its own set of + switches). The value of the attribute is a list of switches. + + In this example, we want to compile all Ada source files with the + @option{-O2} switch, and the resulting project file is as follows + (only the @code{Compiler} package is shown): + + @smallexample + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); + @b{end} Compiler; + @end smallexample + +@item @b{Switches}: +@cindex @code{Switches} + in some cases, we might want to use specific switches + for one or more files. For instance, compiling @file{proc.adb} might not be + possible at high level of optimization because of a compiler issue. + In such a case, the @emph{Switches} + attribute (indexed on the file name) can be used and will override the + switches defined by @emph{Default_Switches}. Our project file would + become: + + @smallexample + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); + @b{for} Switches ("proc.adb") @b{use} ("-O0"); + @b{end} Compiler; + @end smallexample + + @noindent + @code{Switches} can also be given a language name as index instead of a file + name in which case it has the same semantics as @emph{Default_Switches}. + +@item @b{Local_Configuration_Pragmas}: +@cindex @code{Local_Configuration_Pragmas} + this attribute may specify the path + of a file containing configuration pragmas for use by the Ada compiler, + such as @code{pragma Restrictions (No_Tasking)}. These pragmas will be + used for all the sources of the project. + +@end table + +The switches for the other tools are defined in a similar manner through the +@b{Default_Switches} and @b{Switches} attributes, respectively in the +@emph{Builder} package (for @command{gnatmake} and @command{gprbuild}), +the @emph{Binder} package (binding Ada executables) and the @emph{Linker} +package (for linking executables). + +@c --------------------------------------------- +@node Compiling with Project Files +@subsection Compiling with Project Files +@c --------------------------------------------- + +@noindent +Now that our project files are written, let's build our executable. +Here is the command we would use from the command line: + +@smallexample + gnatmake ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +This will automatically build the executables specified through the +@emph{Main} attribute: for each, it will compile or recompile the +sources for which the object file does not exist or is not up-to-date; it +will then run the binder; and finally run the linker to create the +executable itself. + +@command{gnatmake} only knows how to handle Ada files. By using +@command{gprbuild} as a builder, you could automatically manage C files the +same way: create the file @file{utils.c} in the @file{common} directory, +set the attribute @emph{Languages} to @code{"(Ada, C)"}, and run + +@smallexample + gprbuild ^-Pbuild^/PROJECT_FILE=build^ +@end smallexample + +@noindent +Gprbuild knows how to recompile the C files and will +recompile them only if one of their dependencies has changed. No direct +indication on how to build the various elements is given in the +project file, which describes the project properties rather than a +set of actions to be executed. Here is the invocation of +@command{gprbuild} when building a multi-language program: + +@smallexample +$ gprbuild -Pbuild +gcc -c proc.adb +gcc -c pack.adb +gcc -c utils.c +gprbind proc +... +gcc proc.o -o proc +@end smallexample + +@noindent +Notice the three steps described earlier: + +@itemize @bullet +@item The first three gcc commands correspond to the compilation phase. +@item The gprbind command corresponds to the post-compilation phase. +@item The last gcc command corresponds to the final link. + +@end itemize + +@noindent +@cindex @option{-v} option (for GPRbuild) +The default output of GPRbuild's execution is kept reasonably simple and easy +to understand. In particular, some of the less frequently used commands are not +shown, and some parameters are abbreviated. So it is not possible to rerun the +effect ofthe gprbuild command by cut-and-pasting its output. GPRbuild's option +@code{-v} provides a much more verbose output which includes, among other +information, more complete compilation, post-compilation and link commands. + +@c --------------------------------------------- +@node Executable File Names +@subsection Executable File Names +@c --------------------------------------------- + +@noindent +@cindex @code{Executable} +By default, the executable name corresponding to a main file is +computed from the main source file name. Through the attribute +@b{Builder.Executable}, it is possible to change this default. + +For instance, instead of building @command{proc} (or @command{proc.exe} +on Windows), we could configure our project file to build "proc1" +(resp proc1.exe) with the following addition: + +@smallexample @c projectfile + project Build is + ... -- same as before + package Builder is + for Executable ("proc.adb") use "proc1"; + end Builder + end Build; +@end smallexample + +@noindent +@cindex @code{Executable_Suffix} +Attribute @b{Executable_Suffix}, when specified, may change the suffix +of the executable files, when no attribute @code{Executable} applies: +its value replace the platform-specific executable suffix. +The default executable suffix is empty on UNIX and ".exe" on Windows. + +It is also possible to change the name of the produced executable by using the +command line switch @option{-o}. When several mains are defined in the project, +it is not possible to use the @option{-o} switch and the only way to change the +names of the executable is provided by Attributes @code{Executable} and +@code{Executable_Suffix}. + +@c --------------------------------------------- +@node Avoid Duplication With Variables +@subsection Avoid Duplication With Variables +@c --------------------------------------------- + +@noindent +To illustrate some other project capabilities, here is a slightly more complex +project using similar sources and a main program in C: + +@smallexample @c projectfile +project C_Main is + for Languages use ("Ada", "C"); + for Source_Dirs use ("common"); + for Object_Dir use "obj"; + for Main use ("main.c"); + package Compiler is + C_Switches := ("-pedantic"); + for Default_Switches ("C") use C_Switches; + for Default_Switches ("Ada") use ("-gnaty"); + for Switches ("main.c") use C_Switches & ("-g"); + end Compiler; +end C_Main; +@end smallexample + +@noindent +This project has many similarities with the previous one. +As expected, its @code{Main} attribute now refers to a C source. +The attribute @emph{Exec_Dir} is now omitted, thus the resulting +executable will be put in the directory @file{obj}. + +The most noticeable difference is the use of a variable in the +@emph{Compiler} package to store settings used in several attributes. +This avoids text duplication, and eases maintenance (a single place to +modify if we want to add new switches for C files). We will revisit +the use of variables in the context of scenarios (@pxref{Scenarios in +Projects}). + +In this example, we see how the file @file{main.c} can be compiled with +the switches used for all the other C files, plus @option{-g}. +In this specific situation the use of a variable could have been +replaced by a reference to the @code{Default_Switches} attribute: + +@smallexample @c projectfile + for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); +@end smallexample + +@noindent +Note the tick (@emph{'}) used to refer to attributes defined in a package. + +Here is the output of the GPRbuild command using this project: + +@smallexample +$gprbuild -Pc_main +gcc -c -pedantic -g main.c +gcc -c -gnaty proc.adb +gcc -c -gnaty pack.adb +gcc -c -pedantic utils.c +gprbind main.bexch +... +gcc main.o -o main +@end smallexample + +@noindent +The default switches for Ada sources, +the default switches for C sources (in the compilation of @file{lib.c}), +and the specific switches for @file{main.c} have all been taken into +account. + +@c --------------------------------------------- +@node Naming Schemes +@subsection Naming Schemes +@c --------------------------------------------- + +@noindent +Sometimes an Ada software system is ported from one compilation environment to +another (say GNAT), and the file are not named using the default GNAT +conventions. Instead of changing all the file names, which for a variety of +reasons might not be possible, you can define the relevant file naming scheme +in the @b{Naming} package of your project file. + +The naming scheme has two distinct goals for the project manager: it +allows finding of source files when searching in the source +directories, and given a source file name it makes it possible to guess +the associated language, and thus the compiler to use. + +Note that the use by the Ada compiler of pragmas Source_File_Name is not +supported when using project files. You must use the features described in this +paragraph. You can however specify other configuration pragmas +(@pxref{Specifying Configuration Pragmas}). + +The following attributes can be defined in package @code{Naming}: + +@table @asis +@item @b{Casing}: +@cindex @code{Casing} + Its value must be one of @code{"lowercase"} (the default if + unspecified), @code{"uppercase"} or @code{"mixedcase"}. It describes the + casing of file names with regards to the Ada unit name. Given an Ada unit + My_Unit, the file name will respectively be @file{my_unit.adb} (lowercase), + @file{MY_UNIT.ADB} (uppercase) or @file{My_Unit.adb} (mixedcase). + On Windows, file names are case insensitive, so this attribute is + irrelevant. + +@item @b{Dot_Replacement}: +@cindex @code{Dot_Replacement} + This attribute specifies the string that should replace the "." in unit + names. Its default value is @code{"-"} so that a unit + @code{Parent.Child} is expected to be found in the file + @file{parent-child.adb}. The replacement string must satisfy the following + requirements to avoid ambiguities in the naming scheme: + + @itemize - + @item It must not be empty + @item It cannot start or end with an alphanumeric character + @item It cannot be a single underscore + @item It cannot start with an underscore followed by an alphanumeric + @item It cannot contain a dot @code{'.'} except if the entire string + is @code{"."} + + @end itemize + +@item @b{Spec_Suffix} and @b{Specification_Suffix}: +@cindex @code{Spec_Suffix} +@cindex @code{Specification_Suffix} + For Ada, these attributes give the suffix used in file names that contain + specifications. For other languages, they give the extension for files + that contain declaration (header files in C for instance). The attribute + is indexed on the language. + The two attributes are equivalent, but the latter is obsolescent. + If @code{Spec_Suffix ("Ada")} is not specified, then the default is + @code{"^.ads^.ADS^"}. + The value must satisfy the following requirements: + + @itemize - + @item It must not be empty + @item It cannot start with an alphanumeric character + @item It cannot start with an underscore followed by an alphanumeric character + @item It must include at least one dot + + @end itemize + +@item @b{Body_Suffix} and @b{Implementation_Suffix}: +@cindex @code{Body_Suffix} +@cindex @code{Implementation_Suffix} + These attributes give the extension used for file names that contain + code (bodies in Ada). They are indexed on the language. The second + version is obsolescent and fully replaced by the first attribute. + + These attributes must satisfy the same requirements as @code{Spec_Suffix}. + In addition, they must be different from any of the values in + @code{Spec_Suffix}. + If @code{Body_Suffix ("Ada")} is not specified, then the default is + @code{"^.adb^.ADB^"}. + + If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the + same string, then a file name that ends with the longest of these two + suffixes will be a body if the longest suffix is @code{Body_Suffix ("Ada")} + or a spec if the longest suffix is @code{Spec_Suffix ("Ada")}. + + If the suffix does not start with a '.', a file with a name exactly equal + to the suffix will also be part of the project (for instance if you define + the suffix as @code{Makefile}, a file called @file{Makefile} will be part + of the project. This capability is usually not interesting when building. + However, it might become useful when a project is also used to + find the list of source files in an editor, like the GNAT Programming System + (GPS). + +@item @b{Separate_Suffix}: +@cindex @code{Separate_Suffix} + This attribute is specific to Ada. It denotes the suffix used in file names + that contain separate bodies. If it is not specified, then it defaults to + same value as @code{Body_Suffix ("Ada")}. The same rules apply as for the + @code{Body_Suffix} attribute. The only accepted index is "Ada". + +@item @b{Spec} or @b{Specification}: +@cindex @code{Spec} +@cindex @code{Specification} + This attribute @code{Spec} can be used to define the source file name for a + given Ada compilation unit's spec. The index is the literal name of the Ada + unit (case insensitive). The value is the literal base name of the file that + contains this unit's spec (case sensitive or insensitive depending on the + operating system). This attribute allows the definition of exceptions to the + general naming scheme, in case some files do not follow the usual + convention. + + When a source file contains several units, the relative position of the unit + can be indicated. The first unit in the file is at position 1 + + @smallexample @c projectfile + for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; + for Spec ("top") use "foo.a" at 1; + for Spec ("foo") use "foo.a" at 2; + @end smallexample + +@item @b{Body} or @b{Implementation}: +@cindex @code{Body} +@cindex @code{Implementation} + These attribute play the same role as @emph{Spec} for Ada bodies. + +@item @b{Specification_Exceptions} and @b{Implementation_Exceptions}: +@cindex @code{Specification_Exceptions} +@cindex @code{Implementation_Exceptions} + These attributes define exceptions to the naming scheme for languages + other than Ada. They are indexed on the language name, and contain + a list of file names respectively for headers and source code. + + +@end table + +@ifclear vms +For example, the following package models the Apex file naming rules: + +@smallexample @c projectfile +@group + package Naming is + for Casing use "lowercase"; + for Dot_Replacement use "."; + for Spec_Suffix ("Ada") use ".1.ada"; + for Body_Suffix ("Ada") use ".2.ada"; + end Naming; +@end group +@end smallexample +@end ifclear + +@ifset vms +For example, the following package models the DEC Ada file naming rules: + +@smallexample @c projectfile +@group + package Naming is + for Casing use "lowercase"; + for Dot_Replacement use "__"; + for Spec_Suffix ("Ada") use "_.ada"; + for Body_Suffix ("Ada") use ".ada"; + end Naming; +@end group +@end smallexample + +@noindent +(Note that @code{Casing} is @code{"lowercase"} because GNAT gets the file +names in lower case) +@end ifset + +@c --------------------------------------------- +@node Organizing Projects into Subsystems +@section Organizing Projects into Subsystems +@c --------------------------------------------- + +@noindent +A @b{subsystem} is a coherent part of the complete system to be built. It is +represented by a set of sources and one single object directory. A system can +be composed of a single subsystem when it is simple as we have seen in the +first section. Complex systems are usually composed of several interdependent +subsystems. A subsystem is dependent on another subsystem if knowledge of the +other one is required to build it, and in particular if visibility on some of +the sources of this other subsystem is required. Each subsystem is usually +represented by its own project file. + +In this section, the previous example is being extended. Let's assume some +sources of our @code{Build} project depend on other sources. +For instance, when building a graphical interface, it is usual to depend upon +a graphical library toolkit such as GtkAda. Furthermore, we also need +sources from a logging module we had previously written. + +@menu +* Project Dependencies:: +* Cyclic Project Dependencies:: +* Sharing Between Projects:: +* Global Attributes:: +@end menu + +@c --------------------------------------------- +@node Project Dependencies +@subsection Project Dependencies +@c --------------------------------------------- + +@noindent +GtkAda comes with its own project file (appropriately called +@file{gtkada.gpr}), and we will assume we have already built a project +called @file{logging.gpr} for the logging module. With the information provided +so far in @file{build.gpr}, building the application would fail with an error +indicating that the gtkada and logging units that are relied upon by the sources +of this project cannot be found. + +This is easily solved by adding the following @b{with} clauses at the beginning +of our project: + +@smallexample @c projectfile + with "gtkada.gpr"; + with "a/b/logging.gpr"; + project Build is + ... -- as before + end Build; +@end smallexample + +@noindent +@cindex @code{Externally_Built} +When such a project is compiled, @command{gnatmake} will automatically +check the other projects and recompile their sources when needed. It will also +recompile the sources from @code{Build} when needed, and finally create the +executable. In some cases, the implementation units needed to recompile a +project are not available, or come from some third-party and you do not want to +recompile it yourself. In this case, the attribute @b{Externally_Built} to +"true" can be set, indicating to the builder that this project can be assumed +to be up-to-date, and should not be considered for recompilation. In Ada, if +the sources of this externally built project were compiled with another version +of the compiler or with incompatible options, the binder will issue an error. + +The project's @code{with} clause has several effects. It provides source +visibility between projects during the compilation process. It also guarantees +that the necessary object files from @code{Logging} and @code{GtkAda} are +available when linking @code{Build}. + +As can be seen in this example, the syntax for importing projects is similar +to the syntax for importing compilation units in Ada. However, project files +use literal strings instead of names, and the @code{with} clause identifies +project files rather than packages. + +Each literal string after @code{with} is the path +(absolute or relative) to a project file. The @code{.gpr} extension is +optional, although we recommend adding it. If no extension is specified, +and no project file with the @file{^.gpr^.GPR^} extension is found, then +the file is searched for exactly as written in the @code{with} clause, +that is with no extension. + +@cindex project path +When a relative path or a base name is used, the +project files are searched relative to each of the directories in the +@b{project path}. This path includes all the directories found with the +following algorithm, in that order, as soon as a matching file is found, +the search stops: + +@itemize @bullet +@item First, the file is searched relative to the directory that contains the + current project file. +@item +@cindex @code{ADA_PROJECT_PATH} +@cindex @code{GPR_PROJECT_PATH} + Then it is searched relative to all the directories specified in the + ^environment variables^logical names^ @b{GPR_PROJECT_PATH} and + @b{ADA_PROJECT_PATH} (in that order) if they exist. The former is + recommended, the latter is kept for backward compatibility. +@item Finally, it is searched relative to the default project directories. + Such directories depends on the tool used. For @command{gnatmake}, there is + one default project directory: @file{<prefix>/lib/gnat/}. In our example, + @file{gtkada.gpr} is found in the predefined directory if it was installed at + the same root as GNAT. + +@end itemize + +@noindent +Some tools also support extending the project path from the command line, +generally through the @option{-aP}. You can see the value of the project +path by using the @command{gnatls -v} command. + +Any symbolic link will be fully resolved in the directory of the +importing project file before the imported project file is examined. + +Any source file in the imported project can be used by the sources of the +importing project, transitively. +Thus if @code{A} imports @code{B}, which imports @code{C}, the sources of +@code{A} may depend on the sources of @code{C}, even if @code{A} does not +import @code{C} explicitly. However, this is not recommended, because if +and when @code{B} ceases to import @code{C}, some sources in @code{A} will +no longer compile. @command{gprbuild} has a switch @option{--no-indirect-imports} +that will report such indirect dependencies. + +One very important aspect of a project hierarchy is that +@b{a given source can only belong to one project} (otherwise the project manager +would not know which settings apply to it and when to recompile it). It means +that different project files do not usually share source directories or +when they do, they need to specify precisely which project owns which sources +using attribute @code{Source_Files} or equivalent. By contrast, 2 projects +can each own a source with the same base file name as long as they live in +different directories. The latter is not true for Ada Sources because of the +correlation betwen source files and Ada units. + +@c --------------------------------------------- +@node Cyclic Project Dependencies +@subsection Cyclic Project Dependencies +@c --------------------------------------------- + +@noindent +Cyclic dependencies are mostly forbidden: +if @code{A} imports @code{B} (directly or indirectly) then @code{B} +is not allowed to import @code{A}. However, there are cases when cyclic +dependencies would be beneficial. For these cases, another form of import +between projects exists: the @b{limited with}. A project @code{A} that +imports a project @code{B} with a straight @code{with} may also be imported, +directly or indirectly, by @code{B} through a @code{limited with}. + +The difference between straight @code{with} and @code{limited with} is that +the name of a project imported with a @code{limited with} cannot be used in the +project importing it. In particular, its packages cannot be renamed and +its variables cannot be referred to. + +@smallexample @c 0projectfile +with "b.gpr"; +with "c.gpr"; +project A is + For Exec_Dir use B'Exec_Dir; -- ok +end A; + +limited with "a.gpr"; -- Cyclic dependency: A -> B -> A +project B is + For Exec_Dir use A'Exec_Dir; -- not ok +end B; + +with "d.gpr"; +project C is +end C; + +limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A +project D is + For Exec_Dir use A'Exec_Dir; -- not ok +end D; +@end smallexample + +@c --------------------------------------------- +@node Sharing Between Projects +@subsection Sharing Between Projects +@c --------------------------------------------- + +@noindent +When building an application, it is common to have similar needs in severa of +the projects corresponding to the subsystems under construction. For instance, +they will all have the same compilation switches. + +As seen before (@pxref{Tools Options in Project Files}), setting compilation +switches for all sources of a subsystem is simple: it is just a matter of +adding a @code{Compiler.Default_Switches} attribute to each project files with +the same value. Of course, that means duplication of data, and both places need +to be changed in order to recompile the whole application with different +switches. It can become a real problem if there are many subsystems and thus +many project files to edit. + +There are two main approaches to avoiding this duplication: + +@itemize @bullet +@item Since @file{build.gpr} imports @file{logging.gpr}, we could change it + to reference the attribute in Logging, either through a package renaming, + or by referencing the attribute. The following example shows both cases: + + @smallexample @c projectfile + project Logging is + package Compiler is + for Switches ("Ada") use ("-O2"); + end Compiler; + package Binder is + for Switches ("Ada") use ("-E"); + end Binder; + end Logging; + + with "logging.gpr"; + project Build is + package Compiler renames Logging.Compiler; + package Binder is + for Switches ("Ada") use Logging.Binder'Switches ("Ada"); + end Binder; + end Build; + @end smallexample + + @noindent + The solution used for @code{Compiler} gets the same value for all + attributes of the package, but you cannot modify anything from the + package (adding extra switches or some exceptions). The second + version is more flexible, but more verbose. + + If you need to refer to the value of a variable in an imported + project, rather than an attribute, the syntax is similar but uses + a "." rather than an apostrophe. For instance: + + @smallexample @c projectfile + with "imported"; + project Main is + Var1 := Imported.Var; + end Main; + @end smallexample + +@item The second approach is to define the switches in a third project. + That project is setup without any sources (so that, as opposed to + the first example, none of the project plays a special role), and + will only be used to define the attributes. Such a project is + typically called @file{shared.gpr}. + + @smallexample @c projectfile + abstract project Shared is + for Source_Files use (); -- no project + package Compiler is + for Switches ("Ada") use ("-O2"); + end Compiler; + end Shared; + + with "shared.gpr"; + project Logging is + package Compiler renames Shared.Compiler; + end Logging; + + with "shared.gpr"; + project Build is + package Compiler renames Shared.Compiler; + end Build; + @end smallexample + + @noindent + As for the first example, we could have chosen to set the attributes + one by one rather than to rename a package. The reason we explicitly + indicate that @code{Shared} has no sources is so that it can be created + in any directory and we are sure it shares no sources with @code{Build} + or @code{Logging}, which of course would be invalid. + +@cindex project qualifier + Note the additional use of the @b{abstract} qualifier in @file{shared.gpr}. + This qualifier is optional, but helps convey the message that we do not + intend this project to have sources (@pxref{Qualified Projects} for + more qualifiers). +@end itemize + + +@c --------------------------------------------- +@node Global Attributes +@subsection Global Attributes +@c --------------------------------------------- + +@noindent +We have already seen many examples of attributes used to specify a special +option of one of the tools involved in the build process. Most of those +attributes are project specific. That it to say, they only affect the invocation +of tools on the sources of the project where they are defined. + +There are a few additional attributes that apply to all projects in a +hierarchy as long as they are defined on the "main" project. +The main project is the project explicitly mentioned on the command-line. +The project hierarchy is the "with"-closure of the main project. + +Here is a list of commonly used global attributes: + +@table @asis +@item @b{Builder.Global_Configuration_Pragmas}: +@cindex @code{Global_Configuration_Pragmas} + This attribute points to a file that contains configuration pragmas + to use when building executables. These pragmas apply for all + executables build from this project hierarchy. As we have seen before, + additional pragmas can be specified on a per-project basis by setting the + @code{Compiler.Local_Configuration_Pragmas} attribute. + +@item @b{Builder.Global_Compilation_Switches}: +@cindex @code{Global_Compilation_Switches} + This attribute is a list of compiler switches to use when compiling any + source file in the project hierarchy. These switches are used in addition + to the ones defined in the @code{Compiler} package, which only apply to + the sources of the corresponding project. This attribute is indexed on + the name of the language. + +@end table + +Using such global capabilities is convenient. It can also lead to unexpected +behavior. Especially when several subsystems are shared among different main +projects and the different global attributes are not +compatible. Note that using aggregate projects can be a safer and more powerful +replacement to global attributes. + +@c --------------------------------------------- +@node Scenarios in Projects +@section Scenarios in Projects +@c --------------------------------------------- + +@noindent +Various aspects of the projects can be modified based on @b{scenarios}. These +are user-defined modes that change the behavior of a project. Typical +examples are the setup of platform-specific compiler options, or the use of +a debug and a release mode (the former would activate the generation of debug +information, when the second will focus on improving code optimization). + +Let's enhance our example to support a debug and a release modes.The issue is to +let the user choose what kind of system he is building: +use @option{-g} as compiler switches in debug mode and @option{-O2} +in release mode. We will also setup the projects so that we do not share the +same object directory in both modes, otherwise switching from one to the other +might trigger more recompilations than needed or mix objects from the 2 modes. + +One naive approach is to create two different project files, say +@file{build_debug.gpr} and @file{build_release.gpr}, that set the appropriate +attributes as explained in previous sections. This solution does not scale well, +because in presence of multiple projects depending on each other, +you will also have to duplicate the complete hierarchy and adapt the project +files to point to the right copies. + +@cindex scenarios +Instead, project files support the notion of scenarios controlled +by external values. Such values can come from several sources (in decreasing +order of priority): + +@table @asis +@item @b{Command line}: +@cindex @option{-X} + When launching @command{gnatmake} or @command{gprbuild}, the user can pass + extra @option{-X} switches to define the external value. In + our case, the command line might look like + + @smallexample + gnatmake -Pbuild.gpr -Xmode=debug + or gnatmake -Pbuild.gpr -Xmode=release + @end smallexample + +@item @b{^Environment variables^Logical names^}: + When the external value does not come from the command line, it can come from + the value of ^environment variables^logical names^ of the appropriate name. + In our case, if ^an environment variable^a logical name^ called "mode" + exist, its value will be taken into account. + +@item @b{External function second parameter} + +@end table + +@cindex @code{external} +We now need to get that value in the project. The general form is to use +the predefined function @b{external} which returns the current value of +the external. For instance, we could setup the object directory to point to +either @file{obj/debug} or @file{obj/release} by changing our project to + +@smallexample @c projectfile + project Build is + for Object_Dir use "obj/" & external ("mode", "debug"); + ... -- as before + end Build; +@end smallexample + +@noindent +The second parameter to @code{external} is optional, and is the default +value to use if "mode" is not set from the command line or the environment. + +In order to set the switches according to the different scenarios, other +constructs have to be introduced such as typed variables and case statements. + +@cindex typed variable +@cindex case statement +A @b{typed variable} is a variable that +can take only a limited number of values, similar to an enumeration in Ada. +Such a variable can then be used in a @b{case statement} and create conditional +sections in the project. The following example shows how this can be done: + +@smallexample @c projectfile + project Build is + type Mode_Type is ("debug", "release"); -- all possible values + Mode : Mode_Type := external ("mode", "debug"); -- a typed variable + + package Compiler is + case Mode is + when "debug" => + for Switches ("Ada") use ("-g"); + when "release" => + for Switches ("Ada") use ("-O2"); + end case; + end Compiler; + end Build; +@end smallexample + +@noindent +The project has suddenly grown in size, but has become much more flexible. +@code{Mode_Type} defines the only valid values for the @code{mode} variable. If +any other value is read from the environment, an error is reported and the +project is considered as invalid. + +The @code{Mode} variable is initialized with an external value +defaulting to @code{"debug"}. This default could be omitted and that would +force the user to define the value. Finally, we can use a case statement to set the +switches depending on the scenario the user has chosen. + +Most aspects of the projects can depend on scenarios. The notable exception +are project dependencies (@code{with} clauses), which may not depend on a scenario. + +Scenarios work the same way with @b{project hierarchies}: you can either +duplicate a variable similar to @code{Mode} in each of the project (as long +as the first argument to @code{external} is always the same and the type is +the same), or simply set the variable in the @file{shared.gpr} project +(@pxref{Sharing Between Projects}). + +@c --------------------------------------------- +@node Library Projects +@section Library Projects +@c --------------------------------------------- + +@noindent +So far, we have seen examples of projects that create executables. However, +it is also possible to create libraries instead. A @b{library} is a specific +type of subsystem where, for convenience, objects are grouped together +using system-specific means such as archives or windows DLLs. + +Library projects provide a system- and language-independent way of building both @b{static} +and @b{dynamic} libraries. They also support the concept of @b{standalone +libraries} (SAL) which offers two significant properties: the elaboration +(e.g. initialization) of the library is either automatic or very simple; +a change in the +implementation part of the library implies minimal post-compilation actions on +the complete system and potentially no action at all for the rest of the +system in the case of dynamic SALs. + +The GNAT Project Manager takes complete care of the library build, rebuild and +installation tasks, including recompilation of the source files for which +objects do not exist or are not up to date, assembly of the library archive, and +installation of the library (i.e., copying associated source, object and +@file{ALI} files to the specified location). + +@menu +* Building Libraries:: +* Using Library Projects:: +* Stand-alone Library Projects:: +* Installing a library with project files:: +@end menu + +@c --------------------------------------------- +@node Building Libraries +@subsection Building Libraries +@c --------------------------------------------- + +@noindent +Let's enhance our example and transform the @code{logging} subsystem into a +library.In orer to do so, a few changes need to be made to @file{logging.gpr}. +A number of specific attributes needs to be defined: at least @code{Library_Name} +and @code{Library_Dir}; in addition, a number of other attributes can be used +to specify specific aspects of the library. For readablility, it is also +recommended (although not mandatory), to use the qualifier @code{library} in +front of the @code{project} keyword. + +@table @asis +@item @b{Library_Name}: +@cindex @code{Library_Name} + This attribute is the name of the library to be built. There is no + restriction on the name of a library imposed by the project manager; + however, there may be system specific restrictions on the name. + In general, it is recommended to stick to alphanumeric characters + (and possibly underscores) to help portability. + +@item @b{Library_Dir}: +@cindex @code{Library_Dir} + This attribute is the path (absolute or relative) of the directory where + the library is to be installed. In the process of building a library, + the sources are compiled, the object files end up in the explicit or + implicit @code{Object_Dir} directory. When all sources of a library + are compiled, some of the compilation artifacts, including the library itself, + are copied to the library_dir directory. This directory must exists and be + writable. It must also be different from the object directory so that cleanup + activities in the Library_Dir do not affect recompilation needs. + +@end table + +Here is the new version of @file{logging.gpr} that makes it a library: + +@smallexample @c projectfile +library project Logging is -- "library" is optional + for Library_Name use "logging"; -- will create "liblogging.a" on Unix + for Object_Dir use "obj"; + for Library_Dir use "lib"; -- different from object_dir +end Logging; +@end smallexample + +@noindent +Once the above two attributes are defined, the library project is valid and +is enough for building a library with default characteristics. +Other library-related attributes can be used to change the defaults: + +@table @asis +@item @b{Library_Kind}: +@cindex @code{Library_Kind} + The value of this attribute must be either @code{"static"}, @code{"dynamic"} or + @code{"relocatable"} (the latter is a synonym for dynamic). It indicates + which kind of library should be build (the default is to build a + static library, that is an archive of object files that can potentially + be linked into a static executable). When the library is set to be dynamic, + a separate image is created that will be loaded independnently, usually + at the start of the main program execution. Support for dynamic libraries is + very platform specific, for instance on Windows it takes the form of a DLL + while on GNU/Linux, it is a dynamic elf image whose suffix is usually + @file{.so}. Library project files, on the other hand, can be written in + a platform independant way so that the same project file can be used to build + a library on different Oses. + + If you need to build both a static and a dynamic library, it is recommended + use two different object directories, since in some cases some extra code + needs to be generated for the latter. For such cases, one can + either define two different project files, or a single one which uses scenarios + to indicate at the various kinds of library to be build and their + corresponding object_dir. + +@cindex @code{Library_ALI_Dir} +@item @b{Library_ALI_Dir}: + This attribute may be specified to indicate the directory where the ALI + files of the library are installed. By default, they are copied into the + @code{Library_Dir} directory, but as for the executables where we have a + separate @code{Exec_Dir} attribute, you might want to put them in a separate + directory since there can be hundreds of them. The same restrictions as for + the @code{Library_Dir} attribute apply. + +@cindex @code{Library_Version} +@item @b{Library_Version}: + This attribute is platform dependent, and has no effect on VMS and Windows. + On Unix, it is used only for dynamic libraries as the internal + name of the library (the @code{"soname"}). If the library file name (built + from the @code{Library_Name}) is different from the @code{Library_Version}, + then the library file will be a symbolic link to the actual file whose name + will be @code{Library_Version}. This follows the usual installation schemes + for dynamic libraries on many Unix systems. + +@smallexample @c projectfile +@group + project Logging is + Version := "1"; + for Library_Dir use "lib"; + for Library_Name use "logging"; + for Library_Kind use "dynamic"; + for Library_Version use "liblogging.so." & Version; + end Logging; +@end group +@end smallexample + + @noindent + After the compilation, the directory @file{lib} will contain both a + @file{libdummy.so.1} library and a symbolic link to it called + @file{libdummy.so}. + +@cindex @code{Library_GCC} +@item @b{Library_GCC}: + This attribute is the name of the tool to use instead of "gcc" to link shared + libraries. A common use of this attribute is to define a wrapper script that + accomplishes specific actions before calling gcc (which itself is calling the + linker to build the library image). + +@cindex @code{Linker_Options} +@item @b{Linker.Linker_Options}: + This attribute specifies additional switches to be given to the linker when + linking an executable. It is ignored when defined in the main project and + taken into account in all other projects that are imported directly or + indirectly. These switches complement the @code{Linker.Switches} + defined in the main project. This is useful when a particular subsystem + depends on an external library: adding this dependency as a + @code{Linker_Options} in the project of the subsystem is more convenient than + adding it to all the @code{Linker.Switches} of the main projects that depend + upon this subsystem. +@end table + + +@c --------------------------------------------- +@node Using Library Projects +@subsection Using Library Projects +@c --------------------------------------------- + +@noindent +When the builder detects that a project file is a library project file, it +recompiles all sources of the project that need recompilation and rebuild the +library if any of the sources have been recompiled. It then groups all object +files into a single file, which is a shared or a static library. This library +can later on be linked with multiple executables. Note that the use +of shard libraries reduces the size of the final executable and can also reduce +the memory footprint at execution time when the library is shared among several +executables. + +It is also possible to build @b{multi-language libraries}. When using +@command{gprbuild} as a builder, multi-language library projects allow naturally +the creation of multi-language libraries . @command{gnatmake}, does n ot try to +compile non Ada sources. However, when the project is multi-language, it will +automatically link all object files found in the object directory, whether or +not they were compiled from an Ada source file. This specific behavior does not +apply to Ada-only projects which only take into account the objects +corresponding to the sources of the project. + +A non-library project can import a library project. When the builder is invoked +on the former, the library of the latter is only rebuilt when absolutely +necessary. For instance, if a unit of the +library is not up-to-date but non of the executables need this unit, then the +unit is not recompiled and the library is not reassembled. +For instance, let's assume in our example that logging has the following +sources: @file{log1.ads}, @file{log1.adb}, @file{log2.ads} and +@file{log2.adb}. If @file{log1.adb} has been modified, then the library +@file{liblogging} will be rebuilt when compiling all the sources of +@code{Build} only if @file{proc.ads}, @file{pack.ads} or @file{pack.adb} +include a @code{"with Log1"}. + +To ensure that all the sources in the @code{Logging} library are +up to date, and that all the sources of @code{Build} are also up to date, +the following two commands needs to be used: + +@smallexample +gnatmake -Plogging.gpr +gnatmake -Pbuild.gpr +@end smallexample + +@noindent +All @file{ALI} files will also be copied from the object directory to the +library directory. To build executables, @command{gnatmake} will use the +library rather than the individual object files. + +@ifclear vms +Library projects can also be useful to describe a library that need to be used +but, for some reason, cannot be rebuilt. For instance, it is the case when some +of the library sources are not available. Such library projects need simply to +use the @code{Externally_Built} attribute as in the example below: + +@smallexample @c projectfile +library project Extern_Lib is + for Languages use ("Ada", "C"); + for Source_Dirs use ("lib_src"); + for Library_Dir use "lib2"; + for Library_Kind use "dynamic"; + for Library_Name use "l2"; + for Externally_Built use "true"; -- <<<< +end Extern_Lib; +@end smallexample + +@noindent +In the case of externally built libraries, the @code{Object_Dir} +attribute does not need to be specified because it will never be +used. + +The main effect of using such an externally built library project is mostly to +affect the linker command in order to reference the desired library. It can +also be achieved by using @code{Linker.Linker_Options} or @code{Linker.Switches} +in the project corresponding to the subsystem needing this external library. +This latter method is more straightforward in simple cases but when several +subsystems depend upon the same external library, finding the proper place +for the @code{Linker.Linker_Options} might not be easy and if it is +not placed properly, the final link command is likely to present ordering issues. +In such a situation, it is better to use the externally built library project +so that all other subsystems depending on it can declare this dependency thanks +to a project @code{with} clause, which in turn will trigger the builder to find +the proper order of libraries in the final link command. +@end ifclear + +@c --------------------------------------------- +@node Stand-alone Library Projects +@subsection Stand-alone Library Projects +@c --------------------------------------------- + +@noindent +@cindex standalone libraries +A @b{stand-alone library} is a library that contains the necessary code to +elaborate the Ada units that are included in the library. A stand-alone +library is a convenient way to add an Ada subsystem to a more global system +whose main is not in Ada since it makes the elaboration of the Ada part mostly +transparent. However, stand-alone libraries are also useful when the main is in +Ada: they provide a means for minimizing relinking & redeployement of complex +systems when localized changes are made. + +The most proeminent characteristic of a stand-alone library is that it offers a +distinction between interface units and implementation units. Only the former +are visible to units outside the library. A stand-alone library project is thus +characterised by a third attribute, @b{Library_Interface}, in addition to the +two attributes that make a project a Library Project (@code{Library_Name} and +@code{Library_Dir}). + +@table @asis +@item @b{Library_Interface}: +@cindex @code{Library_Interface} + This attribute defines an explicit subset of the units of the project. + Projects importing this library project may only "with" units whose sources + are listed in the @code{Library_Interface}. Other sources are considered + implementation units. + +@smallexample @c projectfile +@group + for Library_Dir use "lib"; + for Library_Name use "loggin"; + for Library_Interface use ("lib1", "lib2"); -- unit names +@end group +@end smallexample + +@end table + +In order to include the elaboration code in the stand-alone library, the binder +is invoked on the closure of the library units creating a package whose name +depends on the library name (^b~logging.ads/b^B$LOGGING.ADS/B^ in the example). +This binder-generated package includes @b{initialization} and @b{finalization} +procedures whose names depend on the library name (@code{logginginit} and +@code{loggingfinal} in the example). The object corresponding to this package is +included in the library. + +@table @asis +@item @b{Library_Auto_Init}: +@cindex @code{Library_Auto_Init} + A dynamic stand-alone Library is automatically initialized + if automatic initialization of Stand-alone Libraries is supported on the + platform and if attribute @b{Library_Auto_Init} is not specified or + is specified with the value "true". A static Stand-alone Library is never + automatically initialized. Specifying "false" for this attribute + prevent automatic initialization. + + When a non-automatically initialized stand-alone library is used in an + executable, its initialization procedure must be called before any service of + the library is used. When the main subprogram is in Ada, it may mean that the + initialization procedure has to be called during elaboration of another + package. + +@item @b{Library_Dir}: +@cindex @code{Library_Dir} + For a stand-alone library, only the @file{ALI} files of the interface units + (those that are listed in attribute @code{Library_Interface}) are copied to + the library directory. As a consequence, only the interface units may be + imported from Ada units outside of the library. If other units are imported, + the binding phase will fail. + +@item @b{Binder.Default_Switches}: + When a stand-alone library is bound, the switches that are specified in + the attribute @b{Binder.Default_Switches ("Ada")} are + used in the call to @command{gnatbind}. + +@item @b{Library_Options}: +@cindex @code{Library_Options} + This attribute may be used to specified additional switches to @command{gcc} + when linking the library. + +@item @b{Library_Src_Dir}: +@cindex @code{Library_Src_Dir} + This attribute defines the location (absolute or relative to the project + directory) where the sources of the interface units are copied at + installation time. + These sources includes the specs of the interface units along with the closure + of sources necessary to compile them successfully. That may include bodies and + subunits, when pragmas @code{Inline} are used, or when there is a generic + units in the spec. This directory cannot point to the object directory or + one of the source directories, but it can point to the library directory, + which is the default value for this attribute. + +@item @b{Library_Symbol_Policy}: +@cindex @code{Library_Symbol_Policy} + This attribute controls the export of symbols and, on some platforms (like + VMS) that have the notions of major and minor IDs built in the library + files, it controls the setting of these IDs. It is not supported on all + platforms (where it will just have no effect). It may have one of the + following values: + + @itemize - + @item @code{"autonomous"} or @code{"default"}: exported symbols are not controlled + @item @code{"compliant"}: if attribute @b{Library_Reference_Symbol_File} + is not defined, then it is equivalent to policy "autonomous". If there + are exported symbols in the reference symbol file that are not in the + object files of the interfaces, the major ID of the library is increased. + If there are symbols in the object files of the interfaces that are not + in the reference symbol file, these symbols are put at the end of the list + in the newly created symbol file and the minor ID is increased. + @item @code{"controlled"}: the attribute @b{Library_Reference_Symbol_File} must be + defined. The library will fail to build if the exported symbols in the + object files of the interfaces do not match exactly the symbol in the + symbol file. + @item @code{"restricted"}: The attribute @b{Library_Symbol_File} must be defined. + The library will fail to build if there are symbols in the symbol file that + are not in the exported symbols of the object files of the interfaces. + Additional symbols in the object files are not added to the symbol file. + @item @code{"direct"}: The attribute @b{Library_Symbol_File} must be defined and + must designate an existing file in the object directory. This symbol file + is passed directly to the underlying linker without any symbol processing. + + @end itemize + +@item @b{Library_Reference_Symbol_File} +@cindex @code{Library_Reference_Symbol_File} + This attribute may define the path name of a reference symbol file that is + read when the symbol policy is either "compliant" or "controlled", on + platforms that support symbol control, such as VMS, when building a + stand-alone library. The path may be an absolute path or a path relative + to the project directory. + +@item @b{Library_Symbol_File} +@cindex @code{Library_Symbol_File} + This attribute may define the name of the symbol file to be created when + building a stand-alone library when the symbol policy is either "compliant", + "controlled" or "restricted", on platforms that support symbol control, + such as VMS. When symbol policy is "direct", then a file with this name + must exist in the object directory. +@end table + + +@c --------------------------------------------- +@node Installing a library with project files +@subsection Installing a library with project files +@c --------------------------------------------- + +@noindent +When using project files, library installation is part of the library build +process. Thus no further action is needed in order to make use of the +libraries that are built as part of the general application build. A usable +version of the library is installed in the directory specified by the +@code{Library_Dir} attribute of the library project file. + +You may want to install a library in a context different from where the library +is built. This situation arises with third party suppliers, who may want +to distribute a library in binary form where the user is not expected to be +able to recompile the library. The simplest option in this case is to provide +a project file slightly different from the one used to build the library, by +using the @code{externally_built} attribute. @ref{Using Library Projects} + +@c --------------------------------------------- +@node Project Extension +@section Project Extension +@c --------------------------------------------- + +@noindent +During development of a large system, it is sometimes necessary to use +modified versions of some of the source files, without changing the original +sources. This can be achieved through the @b{project extension} facility. + +Suppose for instance that our example @code{Build} project is build every night +for the whole team, in some shared directory. A developer usually need to work +on a small part of the system, and might not want to have a copy of all the +sources and all the object files (mostly because that would require too much +disk space, time to recompile everything). He prefers to be able to override +some of the source files in his directory, while taking advantage of all the +object files generated at night. + +Another example can be taken from large software systems, where it is common to have +multiple implementations of a common interface; in Ada terms, multiple +versions of a package body for the same spec. For example, one implementation +might be safe for use in tasking programs, while another might only be used +in sequential applications. This can be modeled in GNAT using the concept +of @emph{project extension}. If one project (the ``child'') @emph{extends} +another project (the ``parent'') then by default all source files of the +parent project are inherited by the child, but the child project can +override any of the parent's source files with new versions, and can also +add new files or remove unnecessary ones. +This facility is the project analog of a type extension in +object-oriented programming. Project hierarchies are permitted (an extending +project may itself be extended), and a project that +extends a project can also import other projects. + +A third example is that of using project extensions to provide different +versions of the same system. For instance, assume that a @code{Common} +project is used by two development branches. One of the branches has now +been frozen, and no further change can be done to it or to @code{Common}. +However, the other development branch still needs evolution of @code{Common}. +Project extensions provide a flexible solution to create a new version +of a subsystem while sharing and reusing as much as possible from the original +one. + +A project extension inherits implicitly all the sources and objects from the +project it extends. It is possible to create a new version of some of the +sources in one of the additional source dirs of the extending project. Those new +versions hide the original versions. Adding new sources or removing existing +ones is also possible. Here is an example on how to extend the project +@code{Build} from previous examples: + +@smallexample @c projectfile + project Work extends "../bld/build.gpr" is + end Work; +@end smallexample + +@noindent +The project after @b{extends} is the one being extended. As usual, it can be +specified using an absolute path, or a path relative to any of the directories +in the project path (@pxref{Project Dependencies}). This project does not +specify source or object directories, so the default value for these attribute +will be used that is to say the current directory (where project @code{Work} is +placed). We can already compile that project with + +@smallexample + gnatmake -Pwork +@end smallexample + +@noindent +If no sources have been placed in the current directory, this command +won't do anything, since this project does not change the +sources it inherited from @code{Build}, therefore all the object files +in @code{Build} and its dependencies are still valid and are reused +automatically. + +Suppose we now want to supply an alternate version of @file{pack.adb} +but use the existing versions of @file{pack.ads} and @file{proc.adb}. +We can create the new file Work's current directory (likely +by copying the one from the @code{Build} project and making changes to +it. If new packages are needed at the same time, we simply create +new files in the source directory of the extending project. + +When we recompile, @command{gnatmake} will now automatically recompile +this file (thus creating @file{pack.o} in the current directory) and +any file that depends on it (thus creating @file{proc.o}). Finally, the +executable is also linked locally. + +Note that we could have obtained the desired behavior using project import +rather than project inheritance. A @code{base} project would contain the +sources for @file{pack.ads} and @file{proc.adb}, and @code{Work} would +import @code{base} and add @file{pack.adb}. In this scenario, @code{base} +cannot contain the original version of @file{pack.adb} otherwise there would be +2 versions of the same unit in the closure of the project and this is not +allowed. Generally speaking, it is not recommended to put the spec and the +body of a unit in different projects since this affects their autonomy and +reusability. + +In a project file that extends another project, it is possible to +indicate that an inherited source is @b{not part} of the sources of the +extending project. This is necessary sometimes when a package spec has +been overridden and no longer requires a body: in this case, it is +necessary to indicate that the inherited body is not part of the sources +of the project, otherwise there will be a compilation error +when compiling the spec. + +@cindex @code{Excluded_Source_Files} +@cindex @code{Excluded_Source_List_File} +For that purpose, the attribute @b{Excluded_Source_Files} is used. +Its value is a list of file names. +It is also possible to use attribute @code{Excluded_Source_List_File}. +Its value is the path of a text file containing one file name per +line. + +@smallexample @c @projectfile +project Work extends "../bld/build.gpr" is + for Source_Files use ("pack.ads"); + -- New spec of Pkg does not need a completion + for Excluded_Source_Files use ("pack.adb"); +end Work; +@end smallexample + +@noindent +An extending project retains all the switches specified in the +extended project. + +@menu +* Project Hierarchy Extension:: +@end menu + +@c --------------------------------------------- +@node Project Hierarchy Extension +@subsection Project Hierarchy Extension +@c --------------------------------------------- + +@noindent +One of the fundamental restrictions in project extension is the following: +@b{A project is not allowed to import directly or indirectly at the same time an +extending project and one of its ancestors}. + +By means of example, consider the following hierarchy of projects. + +@smallexample + a.gpr contains package A1 + b.gpr, imports a.gpr and contains B1, which depends on A1 + c.gpr, imports b.gpr and contains C1, which depends on B1 +@end smallexample + +@noindent +If we want to locally extend the packages @code{A1} and @code{C1}, we need to +create several extending projects: + +@smallexample + a_ext.gpr which extends a.gpr, and overrides A1 + b_ext.gpr which extends b.gpr and imports a_ext.gpr + c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1 +@end smallexample + +@noindent +@smallexample @c projectfile + project A_Ext extends "a.gpr" is + for Source_Files use ("a1.adb", "a1.ads"); + end A_Ext; + + with "a_ext.gpr"; + project B_Ext extends "b.gpr" is + end B_Ext; + + with "b_ext.gpr"; + project C_Ext extends "c.gpr" is + for Source_Files use ("c1.adb"); + end C_Ext; +@end smallexample + +@noindent +The extension @file{b_ext.gpr} is required, even though we are not overriding +any of the sources of @file{b.gpr} because otherwise @file{c_expr.gpr} would +import @file{b.gpr} which itself knows nothing about @file{a_ext.gpr}. + +@cindex extends all +When extending a large system spanning multiple projects, it is often +inconvenient to extend every project in the hierarchy that is impacted by a +small change introduced in a low layer. In such cases, it is possible to create +an @b{implicit extension} of entire hierarchy using @b{extends all} +relationship. + +When the project is extended using @code{extends all} inheritance, all projects +that are imported by it, both directly and indirectly, are considered virtually +extended. That is, the project manager creates implicit projects +that extend every project in the hierarchy; all these implicit projects do not +control sources on their own and use the object directory of +the "extending all" project. + +It is possible to explicitly extend one or more projects in the hierarchy +in order to modify the sources. These extending projects must be imported by +the "extending all" project, which will replace the corresponding virtual +projects with the explicit ones. + +When building such a project hierarchy extension, the project manager will +ensure that both modified sources and sources in implicit extending projects +that depend on them, are recompiled. + +Thus, in our example we could create the following projects instead: + +@smallexample + a_ext.gpr, extends a.gpr and overrides A1 + c_ext.gpr, "extends all" c.gpr, imports a_ext.gpr and overrides C1 + +@end smallexample + +@noindent +@smallexample @c projectfile + project A_Ext extends "a.gpr" is + for Source_Files use ("a1.adb", "a1.ads"); + end A_Ext; + + with "a_ext.gpr"; + project C_Ext extends all "c.gpr" is + for Source_Files use ("c1.adb"); + end C_Ext; +@end smallexample + +@noindent +When building project @file{c_ext.gpr}, the entire modified project space is +considered for recompilation, including the sources of @file{b.gpr} that are +impacted by the changes in @code{A1} and @code{C1}. + +@c --------------------------------------------- +@node Project File Reference +@section Project File Reference +@c --------------------------------------------- + +@noindent +This section describes the syntactic structure of project files, the various +constructs that can be used. Finally, it ends with a summary of all available +attributes. + +@menu +* Project Declaration:: +* Qualified Projects:: +* Declarations:: +* Packages:: +* Expressions:: +* External Values:: +* Typed String Declaration:: +* Variables:: +* Attributes:: +* Case Statements:: +@end menu + +@c --------------------------------------------- +@node Project Declaration +@subsection Project Declaration +@c --------------------------------------------- + +@noindent +Project files have an Ada-like syntax. The minimal project file is: + +@smallexample @c projectfile +@group +project Empty is +end Empty; +@end group +@end smallexample + +@noindent +The identifier @code{Empty} is the name of the project. +This project name must be present after the reserved +word @code{end} at the end of the project file, followed by a semi-colon. + +@b{Identifiers} (ie the user-defined names such as project or variable names) +have the same syntax as Ada identifiers: they must start with a letter, +and be followed by zero or more letters, digits or underscore characters; +it is also illegal to have two underscores next to each other. Identifiers +are always case-insensitive ("Name" is the same as "name"). + +@smallexample +simple_name ::= identifier +name ::= simple_name @{ . simple_name @} +@end smallexample + +@noindent +@b{Strings} are used for values of attributes or as indexes for these +attributes. They are in general case sensitive, except when noted +otherwise (in particular, strings representing file names will be case +insensitive on some systems, so that "file.adb" and "File.adb" both +represent the same file). + +@b{Reserved words} are the same as for standard Ada 95, and cannot +be used for identifiers. In particular, the following words are currently +used in project files, but others could be added later on. In bold are the +extra reserved words in project files: @code{all, at, case, end, for, is, +limited, null, others, package, renames, type, use, when, with, @b{extends}, +@b{external}, @b{project}}. + +@b{Comments} in project files have the same syntax as in Ada, two consecutive +hyphens through the end of the line. + +A project may be an @b{independent project}, entirely defined by a single +project file. Any source file in an independent project depends only +on the predefined library and other source files in the same project. +But a project may also depend on other projects, either by importing them +through @b{with clauses}, or by @b{extending} at most one other project. Both +types of dependency can be used in the same project. + +A path name denotes a project file. It can be absolute or relative. +An absolute path name includes a sequence of directories, in the syntax of +the host operating system, that identifies uniquely the project file in the +file system. A relative path name identifies the project file, relative +to the directory that contains the current project, or relative to a +directory listed in the environment variables ADA_PROJECT_PATH and +GPR_PROJECT_PATH. Path names are case sensitive if file names in the host +operating system are case sensitive. As a special case, the directory +separator can always be "/" even on Windows systems, so that project files +can be made portable across architectures. +The syntax of the environment variable ADA_PROJECT_PATH and +GPR_PROJECT_PATH is a list of directory names separated by colons on UNIX and +semicolons on Windows. + +A given project name can appear only once in a context clause. + +It is illegal for a project imported by a context clause to refer, directly +or indirectly, to the project in which this context clause appears (the +dependency graph cannot contain cycles), except when one of the with clause +in the cycle is a @b{limited with}. +@c ??? Need more details here + +@smallexample @c projectfile +with "other_project.gpr"; +project My_Project extends "extended.gpr" is +end My_Project; +@end smallexample + +@noindent +These dependencies form a @b{directed graph}, potentially cyclic when using +@b{limited with}. The subprogram reflecting the @b{extends} relations is a +tree. + +A project's @b{immediate sources} are the source files directly defined by +that project, either implicitly by residing in the project source directories, +or explicitly through any of the source-related attributes. +More generally, a project sources are the immediate sources of the project +together with the immediate sources (unless overridden) of any +project on which it depends directly or indirectly. + +A @b{project hierarchy} can be created, where projects are children of +other projects. The name of such a child project must be @code{Parent.Child}, +where @code{Parent} is the name of the parent project. In particular, this +makes all @code{with} clauses of the parent project automatically visible +in the child project. + +@smallexample +project ::= context_clause project_declaration + +context_clause ::= @{with_clause@} +with_clause ::= @i{with} path_name @{ , path_name @} ; +path_name ::= string_literal + +project_declaration ::= simple_project_declaration | project_extension +simple_project_declaration ::= + @i{project} @i{<project_>}name @i{is} + @{declarative_item@} + @i{end} <project_>simple_name; +@end smallexample + +@c --------------------------------------------- +@node Qualified Projects +@subsection Qualified Projects +@c --------------------------------------------- + +@noindent +Before the reserved @code{project}, there may be one or two @b{qualifiers}, that +is identifiers or reserved words, to qualify the project. +The current list of qualifiers is: + +@table @asis +@item @b{abstract}: qualifies a project with no sources. Such a + project must either have no declaration of attributes @code{Source_Dirs}, + @code{Source_Files}, @code{Languages} or @code{Source_List_File}, or one of + @code{Source_Dirs}, @code{Source_Files}, or @code{Languages} must be declared + as empty. If it extends another project, the project it extends must also be a + qualified abstract project. +@item @b{standard}: a standard project is a non library project with sources. + This is the default (implicit) qualifier. +@item @b{aggregate}: for future extension +@item @b{aggregate library}: for future extension +@item @b{library}: a library project must declare both attributes + @code{Library_Name} and @code{Library_Dir}. +@item @b{configuration}: a configuration project cannot be in a project tree. + It describes compilers and other tools to @code{gprbuild}. +@end table + + +@c --------------------------------------------- +@node Declarations +@subsection Declarations +@c --------------------------------------------- + +@noindent +Declarations introduce new entities that denote types, variables, attributes, +and packages. Some declarations can only appear immediately within a project +declaration. Others can appear within a project or within a package. + +@smallexample +declarative_item ::= simple_declarative_item + | typed_string_declaration + | package_declaration + +simple_declarative_item ::= variable_declaration + | typed_variable_declaration + | attribute_declaration + | case_construction + | empty_declaration + +empty_declaration ::= @i{null} ; +@end smallexample + +@noindent +An empty declaration is allowed anywhere a declaration is allowed. It has +no effect. + +@c --------------------------------------------- +@node Packages +@subsection Packages +@c --------------------------------------------- + +@noindent +A project file may contain @b{packages}, that group attributes (typically +all the attributes that are used by one of the GNAT tools). + +A package with a given name may only appear once in a project file. +The following packages are currently supported in project files +(See @pxref{Attributes} for the list of attributes that each can contain). + +@table @code +@item Binder + This package specifies characteristics useful when invoking the binder either + directly via the @command{gnat} driver or when using a builder such as + @command{gnatmake} or @command{gprbuild}. @xref{Main Subprograms}. +@item Builder + This package specifies the compilation options used when building an + executable or a library for a project. Most of the options should be + set in one of @code{Compiler}, @code{Binder} or @code{Linker} packages, + but there are some general options that should be defined in this + package. @xref{Main Subprograms}, and @pxref{Executable File Names} in + particular. +@item Check + This package specifies the options used when calling the checking tool + @command{gnatcheck} via the @command{gnat} driver. Its attribute + @b{Default_Switches} has the same semantics as for the package + @code{Builder}. The first string should always be @code{-rules} to specify + that all the other options belong to the @code{-rules} section of the + parameters to @command{gnatcheck}. +@item Compiler + This package specifies the compilation options used by the compiler for + each languages. @xref{Tools Options in Project Files}. +@item Cross_Reference + This package specifies the options used when calling the library tool + @command{gnatxref} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Eliminate + This package specifies the options used when calling the tool + @command{gnatelim} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Finder + This package specifies the options used when calling the search tool + @command{gnatfind} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Gnatls + This package the options to use when invoking @command{gnatls} via the + @command{gnat} driver. +@item Gnatstub + This package specifies the options used when calling the tool + @command{gnatstub} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item IDE + This package specifies the options used when starting an integrated + development environment, for instance @command{GPS} or @command{Gnatbench}. + @xref{The Development Environments}. +@item Linker + This package specifies the options used by the linker. + @xref{Main Subprograms}. +@item Metrics + This package specifies the options used when calling the tool + @command{gnatmetric} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Naming + This package specifies the naming conventions that apply + to the source files in a project. In particular, these conventions are + used to automatically find all source files in the source directories, + or given a file name to find out its language for proper processing. + @xref{Naming Schemes}. +@item Pretty_Printer + This package specifies the options used when calling the formatting tool + @command{gnatpp} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Stack + This package specifies the options used when calling the tool + @command{gnatstack} via the @command{gnat} driver. Its attributes + @b{Default_Switches} and @b{Switches} have the same semantics as for the + package @code{Builder}. +@item Synchronize + This package specifies the options used when calling the tool + @command{gnatsync} via the @command{gnat} driver. + +@end table + +In its simplest form, a package may be empty: + +@smallexample @c projectfile +@group +project Simple is + package Builder is + end Builder; +end Simple; +@end group +@end smallexample + +@noindent +A package may contain @b{attribute declarations}, +@b{variable declarations} and @b{case constructions}, as will be +described below. + +When there is ambiguity between a project name and a package name, +the name always designates the project. To avoid possible confusion, it is +always a good idea to avoid naming a project with one of the +names allowed for packages or any name that starts with @code{gnat}. + +A package can also be defined by a @b{renaming declaration}. The new package +renames a package declared in a different project file, and has the same +attributes as the package it renames. The name of the renamed package +must be the same as the name of the renaming package. The project must +contain a package declaration with this name, and the project +must appear in the context clause of the current project, or be its parent +project. It is not possible to add or override attributes to the renaming +project. If you need to do so, you should declare a standard package, and +assign the value of the attributes one by one (@code{for Switches ("Ada") +use Other_Project.Compiler'Switches ("Ada")}). + +Packages that are renamed in other project files often come from project files +that have no sources: they are just used as templates. Any modification in the +template will be reflected automatically in all the project files that rename +a package from the template. This is a very common way to share settings +between projects. + +@smallexample +package_declaration ::= package_spec | package_renaming +package_spec ::= + @i{package} @i{<package_>}simple_name @i{is} + @{simple_declarative_item@} + @i{end} package_identifier ; +package_renaming ::== + @i{package} @i{<package_>}simple_name @i{renames} @i{<project_>}simple_name.package_identifier ; +@end smallexample + +@c --------------------------------------------- +@node Expressions +@subsection Expressions +@c --------------------------------------------- + +@noindent +An expression is any value that can be assigned to an attribute or a +variable. It is either a litteral value, or a construct requiring runtime +computation by the project manager. In a project file, the computed value of +an expression is either a string or a list of strings. + +A string value is one of: +@itemize @bullet +@item A literal string, for instance @code{"comm/my_proj.gpr"} +@item The name of a variable that evaluates to a string (@pxref{Variables}) +@item The name of an attribute that evaluates to a string (@pxref{Attributes}) +@item An external reference (@pxref{External Values}) +@item A concatenation of the above, as in @code{"prefix_" & Var}. + +@end itemize + +@noindent +A list of strings is one of the following: + +@itemize @bullet +@item A parenthesized comma-separated list of zero or more string expressions, for + instance @code{(File_Name, "gnat.adc", File_Name & ".orig")} or @code{()}. +@item The name of a variable that evaluates to a list of strings +@item The name of an attribute that evaluates to a list of strings +@item A concatenation of a list of strings and a string (as defined above), for + instance @code{("A", "B") & "C"} +@item A concatenation of two lists of strings + +@end itemize + +@noindent +The following is the grammar for expressions + +@smallexample +string_literal ::= "@{string_element@}" -- Same as Ada +string_expression ::= string_literal + | @i{variable_}name + | external_value + | attribute_reference + | ( string_expression @{ & string_expression @} ) +string_list ::= ( string_expression @{ , string_expression @} ) + | @i{string_variable}_name + | @i{string_}attribute_reference +term ::= string_expression | string_list +expression ::= term @{ & term @} -- Concatenation +@end smallexample + +@noindent +Concatenation involves strings and list of strings. As soon as a list of +strings is involved, the result of the concatenation is a list of strings. The +following Ada declarations show the existing operators: + +@smallexample @c ada + function "&" (X : String; Y : String) return String; + function "&" (X : String_List; Y : String) return String_List; + function "&" (X : String_List; Y : String_List) return String_List; +@end smallexample + +@noindent +Here are some specific examples: + +@smallexample @c projectfile +@group + List := () & File_Name; -- One string in this list + List2 := List & (File_Name & ".orig"); -- Two strings + Big_List := List & Lists2; -- Three strings + Illegal := "gnat.adc" & List2; -- Illegal, must start with list +@end group +@end smallexample + +@c --------------------------------------------- +@node External Values +@subsection External Values +@c --------------------------------------------- + +@noindent +An external value is an expression whose value is obtained from the command +that invoked the processing of the current project file (typically a +gnatmake or gprbuild command). + +@smallexample +external_value ::= @i{external} ( string_literal [, string_literal] ) +@end smallexample + +@noindent +The first string_literal is the string to be used on the command line or +in the environment to specify the external value. The second string_literal, +if present, is the default to use if there is no specification for this +external value either on the command line or in the environment. + +Typically, the external value will either exist in the +^environment variables^logical name^ +or be specified on the command line through the +@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. If both +are specified, then the command line value is used, so that a user can more +easily override the value. + +The function @code{external} always returns a string, possibly empty if the +value was not found in the environment and no default was specified in the +call to @code{external}. + +An external reference may be part of a string expression or of a string +list expression, and can therefore appear in a variable declaration or +an attribute declaration. + +Most of the time, this construct is used to initialize typed variables, which +are then used in @b{case} statements to control the value assigned to +attributes in various scenarios. Thus such variables are often called +@b{scenario variables}. + +@c --------------------------------------------- +@node Typed String Declaration +@subsection Typed String Declaration +@c --------------------------------------------- + +@noindent +A @b{type declaration} introduces a discrete set of string literals. +If a string variable is declared to have this type, its value +is restricted to the given set of literals. These are the only named +types in project files. A string type may only be declared at the project +level, not inside a package. + +@smallexample +typed_string_declaration ::= + @i{type} @i{<typed_string_>}_simple_name @i{is} ( string_literal @{, string_literal@} ); +@end smallexample + +@noindent +The string literals in the list are case sensitive and must all be different. +They may include any graphic characters allowed in Ada, including spaces. +Here is an example of a string type declaration: + +@smallexample @c projectfile + type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS"); +@end smallexample + +@noindent +Variables of a string type are called @b{typed variables}; all other +variables are called @b{untyped variables}. Typed variables are +particularly useful in @code{case} constructions, to support conditional +attribute declarations. (@pxref{Case Statements}). + +A string type may be referenced by its name if it has been declared in the same +project file, or by an expanded name whose prefix is the name of the project +in which it is declared. + +@c --------------------------------------------- +@node Variables +@subsection Variables +@c --------------------------------------------- + +@noindent +@b{Variables} store values (strings or list of strings) and can appear +as part of an expression. The declaration of a variable creates the +variable and assigns the value of the expression to it. The name of the +variable is available immediately after the assignment symbol, if you +need to reuse its old value to compute the new value. Before the completion +of its first declaration, the value of a variable defaults to the empty +string (""). + +A @b{typed} variable can be used as part of a @b{case} expression to +compute the value, but it can only be declared once in the project file, +so that all case statements see the same value for the variable. This +provides more consistency and makes the project easier to understand. +The syntax for its declaration is identical to the Ada syntax for an +object declaration. In effect, a typed variable acts as a constant. + +An @b{untyped} variable can be declared and overridden multiple times +within the same project. It is declared implicitly through an Ada +assignment. The first declaration establishes the kind of the variable +(string or list of strings) and successive declarations must respect +the initial kind. Assignments are executed in the order in which they +appear, so the new value replaces the old one and any subsequent reference +to the variable uses the new value. + +A variable may be declared at the project file level, or within a package. + +@smallexample +typed_variable_declaration ::= + @i{<typed_variable_>}simple_name : @i{<typed_string_>}name := string_expression; +variable_declaration ::= @i{<variable_>}simple_name := expression; +@end smallexample + +@noindent +Here are some examples of variable declarations: + +@smallexample @c projectfile +@group + This_OS : OS := external ("OS"); -- a typed variable declaration + That_OS := "GNU/Linux"; -- an untyped variable declaration + + Name := "readme.txt"; + Save_Name := Name & ".saved"; + + Empty_List := (); + List_With_One_Element := ("-gnaty"); + List_With_Two_Elements := List_With_One_Element & "-gnatg"; + Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada"); +@end group +@end smallexample + +@noindent +A @b{variable reference} may take several forms: + +@itemize @bullet +@item The simple variable name, for a variable in the current package (if any) + or in the current project +@item An expanded name, whose prefix is a context name. + +@end itemize + +@noindent +A @b{context} may be one of the following: + +@itemize @bullet +@item The name of an existing package in the current project +@item The name of an imported project of the current project +@item The name of an ancestor project (i.e., a project extended by the current + project, either directly or indirectly) +@item An expanded name whose prefix is an imported/parent project name, and + whose selector is a package name in that project. +@end itemize + + +@c --------------------------------------------- +@node Attributes +@subsection Attributes +@c --------------------------------------------- + +@noindent +A project (and its packages) may have @b{attributes} that define +the project's properties. Some attributes have values that are strings; +others have values that are string lists. + +@smallexample +attribute_declaration ::= + simple_attribute_declaration | indexed_attribute_declaration +simple_attribute_declaration ::= @i{for} attribute_designator @i{use} expression ; +indexed_attribute_declaration ::= + @i{for} @i{<indexed_attribute_>}simple_name ( string_literal) @i{use} expression ; +attribute_designator ::= + @i{<simple_attribute_>}simple_name + | @i{<indexed_attribute_>}simple_name ( string_literal ) +@end smallexample + +@noindent +There are two categories of attributes: @b{simple attributes} +and @b{indexed attributes}. +Each simple attribute has a default value: the empty string (for string +attributes) and the empty list (for string list attributes). +An attribute declaration defines a new value for an attribute, and overrides +the previous value. The syntax of a simple attribute declaration is similar to +that of an attribute definition clause in Ada. + +Some attributes are indexed. These attributes are mappings whose +domain is a set of strings. They are declared one association +at a time, by specifying a point in the domain and the corresponding image +of the attribute. +Like untyped variables and simple attributes, indexed attributes +may be declared several times. Each declaration supplies a new value for the +attribute, and replaces the previous setting. + +Here are some examples of attribute declarations: + +@smallexample @c projectfile + -- simple attributes + for Object_Dir use "objects"; + for Source_Dirs use ("units", "test/drivers"); + + -- indexed attributes + for Body ("main") use "Main.ada"; + for Switches ("main.ada") use ("-v", "-gnatv"); + for Switches ("main.ada") use Builder'Switches ("main.ada") & "-g"; + + -- indexed attributes copy (from package Builder in project Default) + -- The package name must always be specified, even if it is the current + -- package. + for Default_Switches use Default.Builder'Default_Switches; +@end smallexample + +@noindent +Attributes references may be appear anywhere in expressions, and are used +to retrieve the value previously assigned to the attribute. If an attribute +has not been set in a given package or project, its value defaults to the +empty string or the empty list. + +@smallexample +attribute_reference ::= attribute_prefix ' @i{<simple_attribute>_}simple_name [ (string_literal) ] +attribute_prefix ::= @i{project} + | @i{<project_>}simple_name + | package_identifier + | @i{<project_>}simple_name . package_identifier +@end smallexample + +@noindent +Examples are: + +@smallexample @c projectfile + project'Object_Dir + Naming'Dot_Replacement + Imported_Project'Source_Dirs + Imported_Project.Naming'Casing + Builder'Default_Switches ("Ada") +@end smallexample + +@noindent +The prefix of an attribute may be: + +@itemize @bullet +@item @code{project} for an attribute of the current project +@item The name of an existing package of the current project +@item The name of an imported project +@item The name of a parent project that is extended by the current project +@item An expanded name whose prefix is imported/parent project name, + and whose selector is a package name + +@end itemize + +@noindent +Legal attribute names are listed below, including the package in +which they must be declared. These names are case-insensitive. The +semantics for the attributes is explained in great details in other sections. + +The column @emph{index} indicates whether the attribute is an indexed attribute, +and when it is whether its index is case sensitive (sensitive) or not (insensitive), or if case sensitivity depends is the same as file names sensitivity on the +system (file). The text is between brackets ([]) if the index is optional. + +@multitable @columnfractions .3 .1 .2 .4 +@headitem Attribute Name @tab Value @tab Package @tab Index +@headitem General attributes @tab @tab @tab @pxref{Building With Projects} +@item Name @tab string @tab - @tab (Read-only, name of project) +@item Project_Dir @tab string @tab - @tab (Read-only, directory of project) +@item Source_Files @tab list @tab - @tab - +@item Source_Dirs @tab list @tab - @tab - +@item Source_List_File @tab string @tab - @tab - +@item Locally_Removed_Files @tab list @tab - @tab - +@item Excluded_Source_Files @tab list @tab - @tab - +@item Object_Dir @tab string @tab - @tab - +@item Exec_Dir @tab string @tab - @tab - +@item Excluded_Source_Dirs @tab list @tab - @tab - +@item Excluded_Source_Files @tab list @tab - @tab - +@item Excluded_Source_List_File @tab list @tab - @tab - +@item Inherit_Source_Path @tab list @tab - @tab insensitive +@item Languages @tab list @tab - @tab - +@item Main @tab list @tab - @tab - +@item Main_Language @tab string @tab - @tab - +@item Externally_Built @tab string @tab - @tab - +@item Roots @tab list @tab - @tab file +@headitem + Library-related attributes @tab @tab @tab @pxref{Library Projects} +@item Library_Dir @tab string @tab - @tab - +@item Library_Name @tab string @tab - @tab - +@item Library_Kind @tab string @tab - @tab - +@item Library_Version @tab string @tab - @tab - +@item Library_Interface @tab string @tab - @tab - +@item Library_Auto_Init @tab string @tab - @tab - +@item Library_Options @tab list @tab - @tab - +@item Library_Src_Dir @tab string @tab - @tab - +@item Library_ALI_Dir @tab string @tab - @tab - +@item Library_GCC @tab string @tab - @tab - +@item Library_Symbol_File @tab string @tab - @tab - +@item Library_Symbol_Policy @tab string @tab - @tab - +@item Library_Reference_Symbol_File @tab string @tab - @tab - +@item Interfaces @tab list @tab - @tab - +@headitem + Naming @tab @tab @tab @pxref{Naming Schemes} +@item Spec_Suffix @tab string @tab Naming @tab insensitive (language) +@item Body_Suffix @tab string @tab Naming @tab insensitive (language) +@item Separate_Suffix @tab string @tab Naming @tab - +@item Casing @tab string @tab Naming @tab - +@item Dot_Replacement @tab string @tab Naming @tab - +@item Spec @tab string @tab Naming @tab insensitive (Ada unit) +@item Body @tab string @tab Naming @tab insensitive (Ada unit) +@item Specification_Exceptions @tab list @tab Naming @tab insensitive (language) +@item Implementation_Exceptions @tab list @tab Naming @tab insensitive (language) +@headitem + Building @tab @tab @tab @pxref{Switches and Project Files} +@item Default_Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, IDE @tab insensitive (language name) +@item Switches @tab list @tab Builder, Compiler, Binder, Linker, Cross_Reference, Finder, gnatls, Pretty_Printer, gnatstub, Check, Synchronize, Eliminate, Metrics, Stack @tab [file] (file name) +@item Local_Configuration_Pragmas @tab string @tab Compiler @tab - +@item Local_Config_File @tab string @tab insensitive @tab - +@item Global_Configuration_Pragmas @tab list @tab Builder @tab - +@item Global_Compilation_Switches @tab list @tab Builder @tab language +@item Executable @tab string @tab Builder @tab [file] +@item Executable_Suffix @tab string @tab Builder @tab - +@item Global_Config_File @tab string @tab Builder @tab insensitive (language) +@headitem + IDE (used and created by GPS) @tab @tab @tab +@item Remote_Host @tab string @tab IDE @tab - +@item Program_Host @tab string @tab IDE @tab - +@item Communication_Protocol @tab string @tab IDE @tab - +@item Compiler_Command @tab string @tab IDE @tab insensitive (language) +@item Debugger_Command @tab string @tab IDE @tab - +@item Gnatlist @tab string @tab IDE @tab - +@item VCS_Kind @tab string @tab IDE @tab - +@item VCS_File_Check @tab string @tab IDE @tab - +@item VCS_Log_Check @tab string @tab IDE @tab - +@headitem + Configuration files @tab @tab @tab See gprbuild manual +@item Default_Language @tab string @tab - @tab - +@item Run_Path_Option @tab list @tab - @tab - +@item Run_Path_Origin @tab string @tab - @tab - +@item Separate_Run_Path_Options @tab string @tab - @tab - +@item Toolchain_Version @tab string @tab - @tab insensitive +@item Toolchain_Description @tab string @tab - @tab insensitive +@item Object_Generated @tab string @tab - @tab insensitive +@item Objects_Linked @tab string @tab - @tab insensitive +@item Target @tab string @tab - @tab - +@item Library_Builder @tab string @tab - @tab - +@item Library_Support @tab string @tab - @tab - +@item Archive_Builder @tab list @tab - @tab - +@item Archive_Builder_Append_Option @tab list @tab - @tab - +@item Archive_Indexer @tab list @tab - @tab - +@item Archive_Suffix @tab string @tab - @tab - +@item Library_Partial_Linker @tab list @tab - @tab - +@item Shared_Library_Prefix @tab string @tab - @tab - +@item Shared_Library_Suffix @tab string @tab - @tab - +@item Symbolic_Link_Supported @tab string @tab - @tab - +@item Library_Major_Minor_Id_Supported @tab string @tab - @tab - +@item Library_Auto_Init_Supported @tab string @tab - @tab - +@item Shared_Library_Minimum_Switches @tab list @tab - @tab - +@item Library_Version_Switches @tab list @tab - @tab - +@item Library_Install_Name_Option @tab string @tab - @tab - +@item Runtime_Library_Dir @tab string @tab - @tab insensitive +@item Runtime_Source_Dir @tab string @tab - @tab insensitive +@item Driver @tab string @tab Compiler,Binder,Linker @tab insensitive (language) +@item Required_Switches @tab list @tab Compiler,Binder,Linker @tab insensitive (language) +@item Leading_Required_Switches @tab list @tab Compiler @tab insensitive (language) +@item Trailing_Required_Switches @tab list @tab Compiler @tab insensitive (language) +@item Pic_Options @tab list @tab Compiler @tab insensitive (language) +@item Path_Syntax @tab string @tab Compiler @tab insensitive (language) +@item Object_File_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Object_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Multi_Unit_Switches @tab list @tab Compiler @tab insensitive (language) +@item Multi_Unit_Object_Separator @tab string @tab Compiler @tab insensitve (language) +@item Mapping_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Mapping_Spec_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Mapping_body_Suffix @tab string @tab Compiler @tab insensitive (language) +@item Config_File_Switches @tab list @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name @tab string @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name_Index @tab string @tab Compiler @tab insensitive (language) +@item Config_Body_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name_Index @tab string @tab Compiler @tab insensitive (language) +@item Config_Spec_File_Name_Pattern @tab string @tab Compiler @tab insensitive (language) +@item Config_File_Unique @tab string @tab Compiler @tab insensitive (language) +@item Dependency_Switches @tab list @tab Compiler @tab insensitive (language) +@item Dependency_Driver @tab list @tab Compiler @tab insensitive (language) +@item Include_Switches @tab list @tab Compiler @tab insensitive (language) +@item Include_Path @tab string @tab Compiler @tab insensitive (language) +@item Include_Path_File @tab string @tab Compiler @tab insensitive (language) +@item Prefix @tab string @tab Binder @tab insensitive (language) +@item Objects_Path @tab string @tab Binder @tab insensitive (language) +@item Objects_Path_File @tab string @tab Binder @tab insensitive (language) +@item Linker_Options @tab list @tab Linker @tab - +@item Map_File_Options @tab string @tab Linker @tab - +@item Executable_Switches @tab list @tab Linker @tab - +@item Lib_Dir_Switch @tab string @tab Linker @tab - +@item Lib_Name_Switch @tab string @tab Linker @tab - +@item Max_Command_Line_Length @tab string @tab Linker @tab - +@item Response_File_Format @tab string @tab Linker @tab - +@item Response_File_Switches @tab list @tab Linker @tab - +@end multitable + +@c --------------------------------------------- +@node Case Statements +@subsection Case Statements +@c --------------------------------------------- + +@noindent +A @b{case} statement is used in a project file to effect conditional +behavior. Through this statement, you can set the value of attributes +and variables depending on the value previously assigned to a typed +variable. + +All choices in a choice list must be distinct. Unlike Ada, the choice +lists of all alternatives do not need to include all values of the type. +An @code{others} choice must appear last in the list of alternatives. + +The syntax of a @code{case} construction is based on the Ada case statement +(although the @code{null} statement for empty alternatives is optional). + +The case expression must be a typed string variable, whose value is often +given by an external reference (@pxref{External Values}). + +Each alternative starts with the reserved word @code{when}, either a list of +literal strings separated by the @code{"|"} character or the reserved word +@code{others}, and the @code{"=>"} token. +Each literal string must belong to the string type that is the type of the +case variable. +After each @code{=>}, there are zero or more statements. The only +statements allowed in a case construction are other case statements, +attribute declarations and variable declarations. String type declarations and +package declarations are not allowed. Variable declarations are restricted to +variables that have already been declared before the case construction. + +@smallexample +case_statement ::= + @i{case} @i{<typed_variable_>}name @i{is} @{case_item@} @i{end case} ; + +case_item ::= + @i{when} discrete_choice_list => + @{case_statement + | attribute_declaration + | variable_declaration + | empty_declaration@} + +discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} +@end smallexample + +@noindent +Here is a typical example: + +@smallexample @c projectfile +@group +project MyProj is + type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS"); + OS : OS_Type := external ("OS", "GNU/Linux"); + + package Compiler is + case OS is + when "GNU/Linux" | "Unix" => + for Switches ("Ada") use ("-gnath"); + when "NT" => + for Switches ("Ada") use ("-gnatP"); + when others => + null; + end case; + end Compiler; +end MyProj; +@end group +@end smallexample + +@c --------------------------------------------- +@node Tools Supporting Project Files +@chapter Tools Supporting Project Files +@c --------------------------------------------- + +@noindent + + +@menu +* gnatmake and Project Files:: +* The GNAT Driver and Project Files:: +* The Development Environments:: +* Cleaning up with GPRclean:: +@end menu + +@c --------------------------------------------- +@node gnatmake and Project Files +@section gnatmake and Project Files +@c --------------------------------------------- + +@noindent +This section covers several topics related to @command{gnatmake} and +project files: defining ^switches^switches^ for @command{gnatmake} +and for the tools that it invokes; specifying configuration pragmas; +the use of the @code{Main} attribute; building and rebuilding library project +files. + +@menu +* Switches Related to Project Files:: +* Switches and Project Files:: +* Specifying Configuration Pragmas:: +* Project Files and Main Subprograms:: +* Library Project Files:: +@end menu + +@c --------------------------------------------- +@node Switches Related to Project Files +@subsection Switches Related to Project Files +@c --------------------------------------------- + +@noindent +The following switches are used by GNAT tools that support project files: + +@table @option + +@item ^-P^/PROJECT_FILE=^@var{project} +@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) +Indicates the name of a project file. This project file will be parsed with +the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, +if any, and using the external references indicated +by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. +@ifclear vms +There may zero, one or more spaces between @option{-P} and @var{project}. +@end ifclear + +There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. + +Since the Project Manager parses the project file only after all the switches +on the command line are checked, the order of the switches +@option{^-P^/PROJECT_FILE^}, +@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} +or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. + +@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) +Indicates that external variable @var{name} has the value @var{value}. +The Project Manager will use this value for occurrences of +@code{external(name)} when parsing the project file. + +@ifclear vms +If @var{name} or @var{value} includes a space, then @var{name=value} should be +put between quotes. +@smallexample + -XOS=NT + -X"user=John Doe" +@end smallexample +@end ifclear + +Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. +If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same +@var{name}, only the last one is used. + +An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch +takes precedence over the value of the same name in the environment. + +@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) +Indicates the verbosity of the parsing of GNAT project files. + +@ifclear vms +@option{-vP0} means Default; +@option{-vP1} means Medium; +@option{-vP2} means High. +@end ifclear + +@ifset vms +There are three possible options for this qualifier: DEFAULT, MEDIUM and +HIGH. +@end ifset + +The default is ^Default^DEFAULT^: no output for syntactically correct +project files. +If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, +only the last one is used. + +@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^<dir> +@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) +Add directory <dir> at the beginning of the project search path, in order, +after the current working directory. + +@ifclear vms +@item -eL +@cindex @option{-eL} (any project-aware tool) +Follow all symbolic links when processing project files. +@end ifclear + +@item ^--subdirs^/SUBDIRS^=<subdir> +@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) +This switch is recognized by gnatmake and gnatclean. It indicate that the real +directories (except the source directories) are the subdirectories <subdir> +of the directories specified in the project files. This applies in particular +to object directories, library directories and exec directories. If the +subdirectories do not exist, they are created automatically. + +@end table + +@c --------------------------------------------- +@node Switches and Project Files +@subsection Switches and Project Files +@c --------------------------------------------- + +@noindent +@ifset vms +It is not currently possible to specify VMS style qualifiers in the project +files; only Unix style ^switches^switches^ may be specified. +@end ifset + +For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and +@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} +attribute, a @code{Switches} attribute, or both; +as their names imply, these ^switch^switch^-related +attributes affect the ^switches^switches^ that are used for each of these GNAT +components when +@command{gnatmake} is invoked. As will be explained below, these +component-specific ^switches^switches^ precede +the ^switches^switches^ provided on the @command{gnatmake} command line. + +The @code{^Default_Switches^Default_Switches^} attribute is an attribute +indexed by language name (case insensitive) whose value is a string list. +For example: + +@smallexample @c projectfile +@group +package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnaty^-gnaty^", + "^-v^-v^"); +end Compiler; +@end group +@end smallexample + +@noindent +The @code{Switches} attribute is indexed on a file name (which may or may +not be case sensitive, depending +on the operating system) whose value is a string list. For example: + +@smallexample @c projectfile +@group +package Builder is + for Switches ("main1.adb") + use ("^-O2^-O2^"); + for Switches ("main2.adb") + use ("^-g^-g^"); +end Builder; +@end group +@end smallexample + +@noindent +For the @code{Builder} package, the file names must designate source files +for main subprograms. For the @code{Binder} and @code{Linker} packages, the +file names must designate @file{ALI} or source files for main subprograms. +In each case just the file name without an explicit extension is acceptable. + +For each tool used in a program build (@command{gnatmake}, the compiler, the +binder, and the linker), the corresponding package @dfn{contributes} a set of +^switches^switches^ for each file on which the tool is invoked, based on the +^switch^switch^-related attributes defined in the package. +In particular, the ^switches^switches^ +that each of these packages contributes for a given file @var{f} comprise: + +@itemize @bullet +@item the value of attribute @code{Switches (@var{f})}, + if it is specified in the package for the given file, +@item otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, + if it is specified in the package. + +@end itemize + +@noindent +If neither of these attributes is defined in the package, then the package does +not contribute any ^switches^switches^ for the given file. + +When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise +two sets, in the following order: those contributed for the file +by the @code{Builder} package; +and the switches passed on the command line. + +When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, +the ^switches^switches^ passed to the tool comprise three sets, +in the following order: + +@enumerate +@item +the applicable ^switches^switches^ contributed for the file +by the @code{Builder} package in the project file supplied on the command line; + +@item +those contributed for the file by the package (in the relevant project file -- +see below) corresponding to the tool; and + +@item +the applicable switches passed on the command line. +@end enumerate + +The term @emph{applicable ^switches^switches^} reflects the fact that +@command{gnatmake} ^switches^switches^ may or may not be passed to individual +tools, depending on the individual ^switch^switch^. + +@command{gnatmake} may invoke the compiler on source files from different +projects. The Project Manager will use the appropriate project file to +determine the @code{Compiler} package for each source file being compiled. +Likewise for the @code{Binder} and @code{Linker} packages. + +As an example, consider the following package in a project file: + +@smallexample @c projectfile +@group +project Proj1 is + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-g^-g^"); + for Switches ("a.adb") + use ("^-O1^-O1^"); + for Switches ("b.adb") + use ("^-O2^-O2^", + "^-gnaty^-gnaty^"); + end Compiler; +end Proj1; +@end group +@end smallexample + +@noindent +If @command{gnatmake} is invoked with this project file, and it needs to +compile, say, the files @file{a.adb}, @file{b.adb}, and @file{c.adb}, then +@file{a.adb} will be compiled with the ^switch^switch^ +@option{^-O1^-O1^}, +@file{b.adb} with ^switches^switches^ +@option{^-O2^-O2^} +and @option{^-gnaty^-gnaty^}, +and @file{c.adb} with @option{^-g^-g^}. + +The following example illustrates the ordering of the ^switches^switches^ +contributed by different packages: + +@smallexample @c projectfile +@group +project Proj2 is + package Builder is + for Switches ("main.adb") + use ("^-g^-g^", + "^-O1^-)1^", + "^-f^-f^"); + end Builder; +@end group + +@group + package Compiler is + for Switches ("main.adb") + use ("^-O2^-O2^"); + end Compiler; +end Proj2; +@end group +@end smallexample + +@noindent +If you issue the command: + +@smallexample + gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main +@end smallexample + +@noindent +then the compiler will be invoked on @file{main.adb} with the following +sequence of ^switches^switches^ + +@smallexample + ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ +@end smallexample + +@noindent +with the last @option{^-O^-O^} +^switch^switch^ having precedence over the earlier ones; +several other ^switches^switches^ +(such as @option{^-c^-c^}) are added implicitly. + +The ^switches^switches^ +@option{^-g^-g^} +and @option{^-O1^-O1^} are contributed by package +@code{Builder}, @option{^-O2^-O2^} is contributed +by the package @code{Compiler} +and @option{^-O0^-O0^} comes from the command line. + +The @option{^-g^-g^} +^switch^switch^ will also be passed in the invocation of +@command{Gnatlink.} + +A final example illustrates switch contributions from packages in different +project files: + +@smallexample @c projectfile +@group +project Proj3 is + for Source_Files use ("pack.ads", "pack.adb"); + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnata^-gnata^"); + end Compiler; +end Proj3; +@end group + +@group +with "Proj3"; +project Proj4 is + for Source_Files use ("foo_main.adb", "bar_main.adb"); + package Builder is + for Switches ("foo_main.adb") + use ("^-s^-s^", + "^-g^-g^"); + end Builder; +end Proj4; +@end group + +@group +-- Ada source file: +with Pack; +procedure Foo_Main is + @dots{} +end Foo_Main; +@end group +@end smallexample + +@noindent +If the command is +@smallexample +gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato +@end smallexample + +@noindent +then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are +@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and +@option{^-gnato^-gnato^} (passed on the command line). +When the imported package @code{Pack} is compiled, the ^switches^switches^ used +are @option{^-g^-g^} from @code{Proj4.Builder}, +@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, +and @option{^-gnato^-gnato^} from the command line. + +When using @command{gnatmake} with project files, some ^switches^switches^ or +arguments may be expressed as relative paths. As the working directory where +compilation occurs may change, these relative paths are converted to absolute +paths. For the ^switches^switches^ found in a project file, the relative paths +are relative to the project file directory, for the switches on the command +line, they are relative to the directory where @command{gnatmake} is invoked. +The ^switches^switches^ for which this occurs are: +^-I^-I^, +^-A^-A^, +^-L^-L^, +^-aO^-aO^, +^-aL^-aL^, +^-aI^-aI^, as well as all arguments that are not switches (arguments to +^switch^switch^ +^-o^-o^, object files specified in package @code{Linker} or after +-largs on the command line). The exception to this rule is the ^switch^switch^ +^--RTS=^--RTS=^ for which a relative path argument is never converted. + +@c --------------------------------------------- +@node Specifying Configuration Pragmas +@subsection Specifying Configuration Pragmas +@c --------------------------------------------- + +@noindent +When using @command{gnatmake} with project files, if there exists a file +@file{gnat.adc} that contains configuration pragmas, this file will be +ignored. + +Configuration pragmas can be defined by means of the following attributes in +project files: @code{Global_Configuration_Pragmas} in package @code{Builder} +and @code{Local_Configuration_Pragmas} in package @code{Compiler}. + +Both these attributes are single string attributes. Their values is the path +name of a file containing configuration pragmas. If a path name is relative, +then it is relative to the project directory of the project file where the +attribute is defined. + +When compiling a source, the configuration pragmas used are, in order, +those listed in the file designated by attribute +@code{Global_Configuration_Pragmas} in package @code{Builder} of the main +project file, if it is specified, and those listed in the file designated by +attribute @code{Local_Configuration_Pragmas} in package @code{Compiler} of +the project file of the source, if it exists. + +@c --------------------------------------------- +@node Project Files and Main Subprograms +@subsection Project Files and Main Subprograms +@c --------------------------------------------- + +@noindent +When using a project file, you can invoke @command{gnatmake} +with one or several main subprograms, by specifying their source files on the +command line. + +@smallexample + gnatmake ^-P^/PROJECT_FILE=^prj main1 main2 main3 +@end smallexample + +@noindent +Each of these needs to be a source file of the same project, except +when the switch ^-u^/UNIQUE^ is used. + +When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the +same project, one of the project in the tree rooted at the project specified +on the command line. The package @code{Builder} of this common project, the +"main project" is the one that is considered by @command{gnatmake}. + +When ^-u^/UNIQUE^ is used, the specified source files may be in projects +imported directly or indirectly by the project specified on the command line. +Note that if such a source file is not part of the project specified on the +command line, the ^switches^switches^ found in package @code{Builder} of the +project specified on the command line, if any, that are transmitted +to the compiler will still be used, not those found in the project file of +the source file. + +When using a project file, you can also invoke @command{gnatmake} without +explicitly specifying any main, and the effect depends on whether you have +defined the @code{Main} attribute. This attribute has a string list value, +where each element in the list is the name of a source file (the file +extension is optional) that contains a unit that can be a main subprogram. + +If the @code{Main} attribute is defined in a project file as a non-empty +string list and the switch @option{^-u^/UNIQUE^} is not used on the command +line, then invoking @command{gnatmake} with this project file but without any +main on the command line is equivalent to invoking @command{gnatmake} with all +the file names in the @code{Main} attribute on the command line. + +Example: +@smallexample @c projectfile +@group + project Prj is + for Main use ("main1", "main2", "main3"); + end Prj; +@end group +@end smallexample + +@noindent +With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} +is equivalent to +@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1 main2 main3"}. + +When the project attribute @code{Main} is not specified, or is specified +as an empty string list, or when the switch @option{-u} is used on the command +line, then invoking @command{gnatmake} with no main on the command line will +result in all immediate sources of the project file being checked, and +potentially recompiled. Depending on the presence of the switch @option{-u}, +sources from other project files on which the immediate sources of the main +project file depend are also checked and potentially recompiled. In other +words, the @option{-u} switch is applied to all of the immediate sources of the +main project file. + +When no main is specified on the command line and attribute @code{Main} exists +and includes several mains, or when several mains are specified on the +command line, the default ^switches^switches^ in package @code{Builder} will +be used for all mains, even if there are specific ^switches^switches^ +specified for one or several mains. + +But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be +the specific ^switches^switches^ for each main, if they are specified. + +@c --------------------------------------------- +@node Library Project Files +@subsection Library Project Files +@c --------------------------------------------- + +@noindent +When @command{gnatmake} is invoked with a main project file that is a library +project file, it is not allowed to specify one or more mains on the command +line. + +When a library project file is specified, switches ^-b^/ACTION=BIND^ and +^-l^/ACTION=LINK^ have special meanings. + +@itemize @bullet +@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates + to @command{gnatmake} that @command{gnatbind} should be invoked for the + library. + +@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates + to @command{gnatmake} that the binder generated file should be compiled + (in the case of a stand-alone library) and that the library should be built. +@end itemize + + +@c --------------------------------------------- +@node The GNAT Driver and Project Files +@section The GNAT Driver and Project Files +@c --------------------------------------------- + +@noindent +A number of GNAT tools, other than @command{^gnatmake^gnatmake^} +can benefit from project files: +(@command{^gnatbind^gnatbind^}, +@command{^gnatcheck^gnatcheck^}, +@command{^gnatclean^gnatclean^}, +@command{^gnatelim^gnatelim^}, +@command{^gnatfind^gnatfind^}, +@command{^gnatlink^gnatlink^}, +@command{^gnatls^gnatls^}, +@command{^gnatmetric^gnatmetric^}, +@command{^gnatpp^gnatpp^}, +@command{^gnatstub^gnatstub^}, +and @command{^gnatxref^gnatxref^}). However, none of these tools can be invoked +directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). +They must be invoked through the @command{gnat} driver. + +The @command{gnat} driver is a wrapper that accepts a number of commands and +calls the corresponding tool. It was designed initially for VMS platforms (to +convert VMS qualifiers to Unix-style switches), but it is now available on all +GNAT platforms. + +On non-VMS platforms, the @command{gnat} driver accepts the following commands +(case insensitive): + +@itemize @bullet +@item BIND to invoke @command{^gnatbind^gnatbind^} +@item CHOP to invoke @command{^gnatchop^gnatchop^} +@item CLEAN to invoke @command{^gnatclean^gnatclean^} +@item COMP or COMPILE to invoke the compiler +@item ELIM to invoke @command{^gnatelim^gnatelim^} +@item FIND to invoke @command{^gnatfind^gnatfind^} +@item KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} +@item LINK to invoke @command{^gnatlink^gnatlink^} +@item LS or LIST to invoke @command{^gnatls^gnatls^} +@item MAKE to invoke @command{^gnatmake^gnatmake^} +@item NAME to invoke @command{^gnatname^gnatname^} +@item PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} +@item PP or PRETTY to invoke @command{^gnatpp^gnatpp^} +@item METRIC to invoke @command{^gnatmetric^gnatmetric^} +@item STUB to invoke @command{^gnatstub^gnatstub^} +@item XREF to invoke @command{^gnatxref^gnatxref^} + +@end itemize + +@noindent +(note that the compiler is invoked using the command +@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). + +On non-VMS platforms, between @command{gnat} and the command, two +special switches may be used: + +@itemize @bullet +@item @command{-v} to display the invocation of the tool. +@item @command{-dn} to prevent the @command{gnat} driver from removing + the temporary files it has created. These temporary files are + configuration files and temporary file list files. + +@end itemize + +@noindent +The command may be followed by switches and arguments for the invoked +tool. + +@smallexample + gnat bind -C main.ali + gnat ls -a main + gnat chop foo.txt +@end smallexample + +@noindent +Switches may also be put in text files, one switch per line, and the text +files may be specified with their path name preceded by '@@'. + +@smallexample + gnat bind @@args.txt main.ali +@end smallexample + +@noindent +In addition, for commands BIND, COMP or COMPILE, FIND, ELIM, LS or LIST, LINK, +METRIC, PP or PRETTY, STUB and XREF, the project file related switches +(@option{^-P^/PROJECT_FILE^}, +@option{^-X^/EXTERNAL_REFERENCE^} and +@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to +the switches of the invoking tool. + +When GNAT PP or GNAT PRETTY is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all +the immediate sources of the specified project file. + +When GNAT METRIC is used with a project file, but with no source +specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} +with all the immediate sources of the specified project file and with +@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory +of the project. + +In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with +a project file, no source is specified on the command line and +switch ^-U^/ALL_PROJECTS^ is specified on the command line, then +the underlying tool (^gnatpp^gnatpp^ or +^gnatmetric^gnatmetric^) is invoked for all sources of all projects, +not only for the immediate sources of the main project. +@ifclear vms +(-U stands for Universal or Union of the project files of the project tree) +@end ifclear + +For each of the following commands, there is optionally a corresponding +package in the main project. + +@itemize @bullet +@item package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) + +@item package @code{Check} for command CHECK (invoking + @code{^gnatcheck^gnatcheck^}) + +@item package @code{Compiler} for command COMP or COMPILE (invoking the compiler) + +@item package @code{Cross_Reference} for command XREF (invoking + @code{^gnatxref^gnatxref^}) + +@item package @code{Eliminate} for command ELIM (invoking + @code{^gnatelim^gnatelim^}) + +@item package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) + +@item package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) + +@item package @code{Gnatstub} for command STUB + (invoking @code{^gnatstub^gnatstub^}) + +@item package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) + +@item package @code{Check} for command CHECK + (invoking @code{^gnatcheck^gnatcheck^}) + +@item package @code{Metrics} for command METRIC + (invoking @code{^gnatmetric^gnatmetric^}) + +@item package @code{Pretty_Printer} for command PP or PRETTY + (invoking @code{^gnatpp^gnatpp^}) + +@end itemize + +@noindent +Package @code{Gnatls} has a unique attribute @code{Switches}, +a simple variable with a string list value. It contains ^switches^switches^ +for the invocation of @code{^gnatls^gnatls^}. + +@smallexample @c projectfile +@group +project Proj1 is + package gnatls is + for Switches + use ("^-a^-a^", + "^-v^-v^"); + end gnatls; +end Proj1; +@end group +@end smallexample + +@noindent +All other packages have two attribute @code{Switches} and +@code{^Default_Switches^Default_Switches^}. + +@code{Switches} is an indexed attribute, indexed by the +source file name, that has a string list value: the ^switches^switches^ to be +used when the tool corresponding to the package is invoked for the specific +source file. + +@code{^Default_Switches^Default_Switches^} is an attribute, +indexed by the programming language that has a string list value. +@code{^Default_Switches^Default_Switches^ ("Ada")} contains the +^switches^switches^ for the invocation of the tool corresponding +to the package, except if a specific @code{Switches} attribute +is specified for the source file. + +@smallexample @c projectfile +@group +project Proj is + + for Source_Dirs use ("./**"); + + package gnatls is + for Switches use + ("^-a^-a^", + "^-v^-v^"); + end gnatls; +@end group +@group + + package Compiler is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-gnatv^-gnatv^", + "^-gnatwa^-gnatwa^"); + end Binder; +@end group +@group + + package Binder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^", + "^-e^-e^"); + end Binder; +@end group +@group + + package Linker is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-C^-C^"); + for Switches ("main.adb") + use ("^-C^-C^", + "^-v^-v^", + "^-v^-v^"); + end Linker; +@end group +@group + + package Finder is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^"); + end Finder; +@end group +@group + + package Cross_Reference is + for ^Default_Switches^Default_Switches^ ("Ada") + use ("^-a^-a^", + "^-f^-f^", + "^-d^-d^", + "^-u^-u^"); + end Cross_Reference; +end Proj; +@end group +@end smallexample + +@noindent +With the above project file, commands such as + +@smallexample + ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ + ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ + ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ + ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ + ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ +@end smallexample + +@noindent +will set up the environment properly and invoke the tool with the switches +found in the package corresponding to the tool: +@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, +except @code{Switches ("main.adb")} +for @code{^gnatlink^gnatlink^}. +It is also possible to invoke some of the tools, +(@code{^gnatcheck^gnatcheck^}, +@code{^gnatmetric^gnatmetric^}, +and @code{^gnatpp^gnatpp^}) +on a set of project units thanks to the combination of the switches +@option{-P}, @option{-U} and possibly the main unit when one is interested +in its closure. For instance, +@smallexample +gnat metric -Pproj +@end smallexample + +@noindent +will compute the metrics for all the immediate units of project +@code{proj}. +@smallexample +gnat metric -Pproj -U +@end smallexample + +@noindent +will compute the metrics for all the units of the closure of projects +rooted at @code{proj}. +@smallexample +gnat metric -Pproj -U main_unit +@end smallexample + +@noindent +will compute the metrics for the closure of units rooted at +@code{main_unit}. This last possibility relies implicitly +on @command{gnatbind}'s option @option{-R}. But if the argument files for the +tool invoked by the the @command{gnat} driver are explicitly specified +either directly or through the tool @option{-files} option, then the tool +is called only for these explicitly specified files. + +@c --------------------------------------------- +@node The Development Environments +@section The Development Environments +@c --------------------------------------------- + +@noindent +See the appropriate manuals for more details. These environments will +store a number of settings in the project itself, when they are meant +to be shared by the whole team working on the project. Here are the +attributes defined in the package @b{IDE} in projects. + +@table @code +@item Remote_Host +This is a simple attribute. Its value is a string that designates the remote +host in a cross-compilation environment, to be used for remote compilation and +debugging. This field should not be specified when running on the local +machine. + +@item Program_Host +This is a simple attribute. Its value is a string that specifies the +name of IP address of the embedded target in a cross-compilation environment, +on which the program should execute. + +@item Communication_Protocol +This is a simple string attribute. Its value is the name of the protocol +to use to communicate with the target in a cross-compilation environment, +e.g.@: @code{"wtx"} or @code{"vxworks"}. + +@item Compiler_Command +This is an associative array attribute, whose domain is a language name. Its +value is string that denotes the command to be used to invoke the compiler. +The value of @code{Compiler_Command ("Ada")} is expected to be compatible with +gnatmake, in particular in the handling of switches. + +@item Debugger_Command +This is simple attribute, Its value is a string that specifies the name of +the debugger to be used, such as gdb, powerpc-wrs-vxworks-gdb or gdb-4. + +@item Default_Switches +This is an associative array attribute. Its indexes are the name of the +external tools that the GNAT Programming System (GPS) is supporting. Its +value is a list of switches to use when invoking that tool. + +@item Gnatlist +This is a simple attribute. Its value is a string that specifies the name +of the @command{gnatls} utility to be used to retrieve information about the +predefined path; e.g., @code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. +@item VCS_Kind +This is a simple attribute. Its value is a string used to specify the +Version Control System (VCS) to be used for this project, e.g.@: CVS, RCS +ClearCase or Perforce. + +@item VCS_File_Check +This is a simple attribute. Its value is a string that specifies the +command used by the VCS to check the validity of a file, either +when the user explicitly asks for a check, or as a sanity check before +doing the check-in. + +@item VCS_Log_Check +This is a simple attribute. Its value is a string that specifies +the command used by the VCS to check the validity of a log file. + +@item VCS_Repository_Root +The VCS repository root path. This is used to create tags or branches +of the repository. For subversion the value should be the @code{URL} +as specified to check-out the working copy of the repository. + +@item VCS_Patch_Root +The local root directory to use for building patch file. All patch chunks +will be relative to this path. The root project directory is used if +this value is not defined. + +@end table + +@c --------------------------------------------- +@node Cleaning up with GPRclean +@section Cleaning up with GPRclean +@c --------------------------------------------- + +@noindent +The GPRclean tool removes the files created by GPRbuild. +At a minimum, to invoke GPRclean you must specify a main project file +in a command such as @code{gprclean proj.gpr} or @code{gprclean -P proj.gpr}. + +Examples of invocation of GPRclean: + +@smallexample + gprclean -r prj1.gpr + gprclean -c -P prj2.gpr +@end smallexample + +@menu +* Switches for GPRclean:: +@end menu + +@c --------------------------------------------- +@node Switches for GPRclean +@subsection Switches for GPRclean +@c --------------------------------------------- + +@noindent +The switches for GPRclean are: + +@itemize @bullet +@item @option{--config=<main config project file name>} : Specify the + configuration project file name + +@item @option{--autoconf=<config project file name>} + + This specifies a configuration project file name that already exists or will + be created automatically. Option @option{--autoconf=} + cannot be specified more than once. If the configuration project file + specified with @option{--autoconf=} exists, then it is used. Otherwise, + @value{gprconfig} is invoked to create it automatically. + +@item @option{-c} : Only delete compiler-generated files. Do not delete + executables and libraries. + +@item @option{-f} : Force deletions of unwritable files + +@item @option{-F} : Display full project path name in brief error messages + +@item @option{-h} : Display this message + +@item @option{-n} : Do not delete files, only list files to delete + +@item @option{-P<proj>} : Use Project File @emph{<proj>}. + +@item @option{-q} : Be quiet/terse. There is no output, except to report + problems. + +@item @option{-r} : (recursive) Clean all projects referenced by the main + project directly or indirectly. Without this switch, GPRclean only + cleans the main project. + +@item @option{-v} : Verbose mode + +@item @option{-vPx} : Specify verbosity when parsing Project Files. + x = 0 (default), 1 or 2. + +@item @option{-Xnm=val} : Specify an external reference for Project Files. + +@end itemize + + + diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index 39b6288520e..9d3bcd7bb2b 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -26,6 +26,38 @@ with SCOs; use SCOs; procedure Put_SCOs is + Ctr : Nat; + + procedure Output_Range (T : SCO_Table_Entry); + -- Outputs T.From and T.To in line:col-line:col format + + procedure Output_Source_Location (Loc : Source_Location); + -- Output source location in line:col format + + ------------------ + -- Output_Range -- + ------------------ + + procedure Output_Range (T : SCO_Table_Entry) is + begin + Output_Source_Location (T.From); + Write_Info_Char ('-'); + Output_Source_Location (T.To); + end Output_Range; + + ---------------------------- + -- Output_Source_Location -- + ---------------------------- + + procedure Output_Source_Location (Loc : Source_Location) is + begin + Write_Info_Nat (Nat (Loc.Line)); + Write_Info_Char (':'); + Write_Info_Nat (Nat (Loc.Col)); + end Output_Source_Location; + +-- Start of processing for Put_SCOs + begin -- Loop through entries in SCO_Unit_Table @@ -64,35 +96,16 @@ begin Output_SCO_Line : declare T : SCO_Table_Entry renames SCO_Table.Table (Start); - procedure Output_Range (T : SCO_Table_Entry); - -- Outputs T.From and T.To in line:col-line:col format - - ------------------ - -- Output_Range -- - ------------------ - - procedure Output_Range (T : SCO_Table_Entry) is - begin - Write_Info_Nat (Nat (T.From.Line)); - Write_Info_Char (':'); - Write_Info_Nat (Nat (T.From.Col)); - Write_Info_Char ('-'); - Write_Info_Nat (Nat (T.To.Line)); - Write_Info_Char (':'); - Write_Info_Nat (Nat (T.To.Col)); - end Output_Range; - - -- Start of processing for Output_SCO_Line - begin - Write_Info_Initiate ('C'); - Write_Info_Char (T.C1); - case T.C1 is -- Statements when 'S' => + Write_Info_Initiate ('C'); + Write_Info_Char ('S'); + + Ctr := 0; loop Write_Info_Char (' '); @@ -105,8 +118,22 @@ begin Start := Start + 1; pragma Assert (SCO_Table.Table (Start).C1 = 's'); + + Ctr := Ctr + 1; + + -- Up to 6 items on a line, if more than 6 items, + -- continuation lines are marked Cs. + + if Ctr = 6 then + Write_Info_Terminate; + Write_Info_Initiate ('C'); + Write_Info_Char ('s'); + Ctr := 0; + end if; end loop; + Write_Info_Terminate; + -- Statement continuations should not occur since they -- are supposed to have been handled in the loop above. @@ -116,41 +143,59 @@ begin -- Decision when 'I' | 'E' | 'P' | 'W' | 'X' => - if T.C2 = ' ' then - Start := Start + 1; - end if; + Start := Start + 1; - -- Loop through table entries for this decision + -- For disabled pragma, skip decision output - loop - declare - T : SCO_Table_Entry renames SCO_Table.Table (Start); + if T.C1 = 'P' and then T.C2 = 'd' then + while not SCO_Table.Table (Start).Last loop + Start := Start + 1; + end loop; + + -- For all other cases output decision line - begin + else + Write_Info_Initiate ('C'); + Write_Info_Char (T.C1); + + if T.C1 /= 'X' then Write_Info_Char (' '); + Output_Source_Location (T.From); + end if; - if T.C1 = '!' or else - T.C1 = '^' or else - T.C1 = '&' or else - T.C1 = '|' - then - Write_Info_Char (T.C1); + -- Loop through table entries for this decision - else - Write_Info_Char (T.C2); - Output_Range (T); - end if; + loop + declare + T : SCO_Table_Entry + renames SCO_Table.Table (Start); - exit when T.Last; - Start := Start + 1; - end; - end loop; + begin + Write_Info_Char (' '); + + if T.C1 = '!' or else + T.C1 = '&' or else + T.C1 = '|' + then + Write_Info_Char (T.C1); + Output_Source_Location (T.From); + + else + Write_Info_Char (T.C2); + Output_Range (T); + end if; + + exit when T.Last; + Start := Start + 1; + end; + end loop; + + Write_Info_Terminate; + end if; when others => raise Program_Error; end case; - - Write_Info_Terminate; end Output_SCO_Line; Start := Start + 1; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index c84996e3ba7..362d1d8cead 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2010, 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- -- @@ -403,7 +403,6 @@ package body Repinfo is if List_Representation_Info >= 2 then List_Object_Info (E); end if; - end if; -- Recurse into nested package, but not if they are package diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index a57ac4c66ee..f7d97baec67 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -256,6 +256,14 @@ package body Restrict is -- Start of processing for Check_Restriction begin + -- In CodePeer mode, we do not want to check for any restriction, or + -- set additional restrictions than those already set in gnat1drv.adb + -- so that we have consistency between each compilation. + + if CodePeer_Mode then + return; + end if; + if UI_Is_In_Int_Range (V) then VV := Integer (UI_To_Int (V)); else diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 32323fc593e..9742cb20b95 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -1333,8 +1333,8 @@ package body Rtsfind is -- The RT_Unit_Table entry that may need updating begin - -- If entry is not set, set it now, and indicate that it - -- was loaded through an explicit context clause.. + -- If entry is not set, set it now, and indicate that it was + -- loaded through an explicit context clause. if No (U.Entity) then U := (Entity => E, diff --git a/gcc/ada/s-auxdec-vms-alpha.adb b/gcc/ada/s-auxdec-vms-alpha.adb index 294eb1d844b..063b296f3ac 100644 --- a/gcc/ada/s-auxdec-vms-alpha.adb +++ b/gcc/ada/s-auxdec-vms-alpha.adb @@ -29,6 +29,8 @@ -- -- ------------------------------------------------------------------------------ +-- This is the Alpha/VMS version. + pragma Style_Checks (All_Checks); -- Turn off alpha ordering check on subprograms, this unit is laid -- out to correspond to the declarations in the DEC 83 System unit. @@ -36,76 +38,6 @@ pragma Style_Checks (All_Checks); with System.Machine_Code; use System.Machine_Code; package body System.Aux_DEC is - ----------------------------------- - -- Operations on Largest_Integer -- - ----------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type LIU is mod 2 ** Largest_Integer'Size; - -- Unsigned type of same length as Largest_Integer - - function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer); - function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU); - - function "not" (Left : Largest_Integer) return Largest_Integer is - begin - return To_LI (not From_LI (Left)); - end "not"; - - function "and" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) and From_LI (Right)); - end "and"; - - function "or" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) or From_LI (Right)); - end "or"; - - function "xor" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) xor From_LI (Right)); - end "xor"; - - -------------------------------------- - -- Arithmetic Operations on Address -- - -------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - Asiz : constant Integer := Integer (Address'Size) - 1; - - type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1; - -- Signed type of same size as Address - - function To_A is new Ada.Unchecked_Conversion (SA, Address); - function From_A is new Ada.Unchecked_Conversion (Address, SA); - - function "+" (Left : Address; Right : Integer) return Address is - begin - return To_A (From_A (Left) + SA (Right)); - end "+"; - - function "+" (Left : Integer; Right : Address) return Address is - begin - return To_A (SA (Left) + From_A (Right)); - end "+"; - - function "-" (Left : Address; Right : Address) return Integer is - pragma Unsuppress (All_Checks); - -- Because this can raise Constraint_Error for 64-bit addresses - begin - return Integer (From_A (Left) - From_A (Right)); - end "-"; - - function "-" (Left : Address; Right : Integer) return Address is - begin - return To_A (From_A (Left) - SA (Right)); - end "-"; - ------------------------ -- Fetch_From_Address -- ------------------------ @@ -130,171 +62,6 @@ package body System.Aux_DEC is Ptr.all := T; end Assign_To_Address; - --------------------------------- - -- Operations on Unsigned_Byte -- - --------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) ??? - - type BU is mod 2 ** Unsigned_Byte'Size; - -- Unsigned type of same length as Unsigned_Byte - - function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte); - function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU); - - function "not" (Left : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (not From_B (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) and From_B (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) or From_B (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) xor From_B (Right)); - end "xor"; - - --------------------------------- - -- Operations on Unsigned_Word -- - --------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) ??? - - type WU is mod 2 ** Unsigned_Word'Size; - -- Unsigned type of same length as Unsigned_Word - - function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word); - function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU); - - function "not" (Left : Unsigned_Word) return Unsigned_Word is - begin - return To_W (not From_W (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) and From_W (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) or From_W (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) xor From_W (Right)); - end "xor"; - - ------------------------------------- - -- Operations on Unsigned_Longword -- - ------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) ??? - - type LWU is mod 2 ** Unsigned_Longword'Size; - -- Unsigned type of same length as Unsigned_Longword - - function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword); - function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU); - - function "not" (Left : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (not From_LW (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) and From_LW (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) or From_LW (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) xor From_LW (Right)); - end "xor"; - - ------------------------------- - -- Operations on Unsigned_32 -- - ------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) ??? - - type U32 is mod 2 ** Unsigned_32'Size; - -- Unsigned type of same length as Unsigned_32 - - function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32); - function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32); - - function "not" (Left : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (not From_U32 (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) and From_U32 (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) or From_U32 (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) xor From_U32 (Right)); - end "xor"; - - ------------------------------------- - -- Operations on Unsigned_Quadword -- - ------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) ??? - - type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size - -- Unsigned type of same length as Unsigned_Quadword - - function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword); - function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU); - - function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (not From_QW (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) and From_QW (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) or From_QW (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) xor From_QW (Right)); - end "xor"; - ----------------------- -- Clear_Interlocked -- ----------------------- diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads index a54f44f8e3f..1480a441887 100644 --- a/gcc/ada/s-auxdec-vms_64.ads +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -112,6 +112,9 @@ package System.Aux_DEC is function "-" (Left : Address; Right : Address) return Integer; function "-" (Left : Address; Right : Integer) return Address; + pragma Import (Intrinsic, "+"); + pragma Import (Intrinsic, "-"); + generic type Target is private; function Fetch_From_Address (A : Address) return Target; @@ -227,16 +230,16 @@ package System.Aux_DEC is type Unsigned_Quadword_Array is array (Integer range <>) of Unsigned_Quadword; - function To_Address (X : Integer) return Address; + function To_Address (X : Integer) return Short_Address; pragma Pure_Function (To_Address); - function To_Address_Long (X : Unsigned_Longword) return Address; + function To_Address_Long (X : Unsigned_Longword) return Short_Address; pragma Pure_Function (To_Address_Long); - function To_Integer (X : Address) return Integer; + function To_Integer (X : Short_Address) return Integer; - function To_Unsigned_Longword (X : Address) return Unsigned_Longword; - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; + function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword; + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; -- Conventional names for static subtypes of type UNSIGNED_LONGWORD @@ -461,12 +464,10 @@ private -- them intrinsic, since the backend can handle them, but the front -- end is not prepared to deal with them, so at least inline them. - pragma Inline_Always ("+"); - pragma Inline_Always ("-"); - pragma Inline_Always ("not"); - pragma Inline_Always ("and"); - pragma Inline_Always ("or"); - pragma Inline_Always ("xor"); + pragma Import (Intrinsic, "not"); + pragma Import (Intrinsic, "and"); + pragma Import (Intrinsic, "or"); + pragma Import (Intrinsic, "xor"); -- Other inlined subprograms @@ -656,31 +657,31 @@ private -- want warnings when we compile on such systems. function To_Address_A is new - Ada.Unchecked_Conversion (Integer, Address); + Ada.Unchecked_Conversion (Integer, Short_Address); pragma Pure_Function (To_Address_A); - function To_Address (X : Integer) return Address + function To_Address (X : Integer) return Short_Address renames To_Address_A; pragma Pure_Function (To_Address); function To_Address_Long_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Address); + Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address); pragma Pure_Function (To_Address_Long_A); - function To_Address_Long (X : Unsigned_Longword) return Address + function To_Address_Long (X : Unsigned_Longword) return Short_Address renames To_Address_Long_A; pragma Pure_Function (To_Address_Long); function To_Integer_A is new - Ada.Unchecked_Conversion (Address, Integer); + Ada.Unchecked_Conversion (Short_Address, Integer); - function To_Integer (X : Address) return Integer + function To_Integer (X : Short_Address) return Integer renames To_Integer_A; function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Address, Unsigned_Longword); + Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); - function To_Unsigned_Longword (X : Address) return Unsigned_Longword + function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword renames To_Unsigned_Longword_A; function To_Unsigned_Longword_A is new diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 7d5f1107add..345e9a570ea 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -59,6 +59,9 @@ package System.CRTL is type size_t is mod 2 ** Standard'Address_Size; + type ssize_t is range -(2 ** (Standard'Address_Size - 1)) + .. +(2 ** (Standard'Address_Size - 1)) - 1; + type Filename_Encoding is (UTF8, ASCII_8bits, Unspecified); for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1, Unspecified => 2); pragma Convention (C, Filename_Encoding); @@ -187,10 +190,10 @@ package System.CRTL is function close (fd : int) return int; pragma Import (C, close, "close"); - function read (fd : int; buffer : chars; nbytes : int) return int; + function read (fd : int; buffer : chars; count : size_t) return ssize_t; pragma Import (C, read, "read"); - function write (fd : int; buffer : chars; nbytes : int) return int; + function write (fd : int; buffer : chars; count : size_t) return ssize_t; pragma Import (C, write, "write"); end System.CRTL; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index 60a96e427cf..185fc52cff9 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -104,7 +104,7 @@ package body System.File_IO is File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case - -- sensitive (e.g., in OS/2, set False). + -- sensitive (e.g., in Windows, set False). ----------------------- -- Local Subprograms -- diff --git a/gcc/ada/s-filofl.ads b/gcc/ada/s-filofl.ads index 319fc8f41f0..e3aba15d571 100644 --- a/gcc/ada/s-filofl.ads +++ b/gcc/ada/s-filofl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index 02231a46328..3d33f6c9e13 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -367,11 +367,27 @@ package body System.Interrupts is -------------- procedure Finalize (Object : in out Static_Interrupt_Protection) is + function State + (Int : System.Interrupt_Management.Interrupt_ID) return Character; + pragma Import (C, State, "__gnat_get_interrupt_state"); + -- Get interrupt state for interrupt number Int. Defined in init.c + + Default : constant Character := 's'; + -- 's' Interrupt_State pragma set state to System (use "default" + -- system handler) + begin -- ??? loop to be executed only when we're not doing library level -- finalization, since in this case all interrupt tasks are gone. - if not Interrupt_Manager'Terminated then + -- If the Abort_Task signal is set to system, it means that we cannot + -- reset interrupt handlers since this would require sending the abort + -- signal to the Server_Task + + if not Interrupt_Manager'Terminated + and then State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then for N in reverse Object.Previous_Handlers'Range loop Interrupt_Manager.Attach_Handler (New_Handler => Object.Previous_Handlers (N).Handler, diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index be1165db448..5614553c77b 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -59,8 +59,7 @@ package System.Interrupt_Management is type Interrupt_Set is array (Interrupt_ID) of Boolean; - subtype Signal_ID is Interrupt_ID - range 0 .. Interfaces.C."-" (System.OS_Interface.NSIG, 1); + subtype Signal_ID is Interrupt_ID range 0 .. System.OS_Interface.NSIG - 1; type Signal_Set is array (Signal_ID) of Boolean; @@ -74,7 +73,7 @@ package System.Interrupt_Management is -- convention that ID zero is not used for any "real" signals, and SIGRARE -- = 0 when SIGRARE is not one of the locally supported signals, we can -- write: - -- Reserved (SIGRARE) := true; + -- Reserved (SIGRARE) := True; -- and the initialization code will be portable. Abort_Task_Interrupt : Signal_ID; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index f7341367688..c7ca149ab68 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -2309,8 +2309,11 @@ package body System.OS_Lib is N : Integer) return Integer is begin - return Integer (System.CRTL.read - (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); + return + Integer (System.CRTL.read + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); end Read; ----------------- @@ -2718,8 +2721,11 @@ package body System.OS_Lib is N : Integer) return Integer is begin - return Integer (System.CRTL.write - (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); + return + Integer (System.CRTL.write + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); end Write; end System.OS_Lib; diff --git a/gcc/ada/s-osinte-hpux-dce.ads b/gcc/ada/s-osinte-hpux-dce.ads index 417aae98e91..f39cbfdec34 100644 --- a/gcc/ada/s-osinte-hpux-dce.ads +++ b/gcc/ada/s-osinte-hpux-dce.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index 323fc158f05..6c0f1353762 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads index 0eda1ef603c..dd5f1eb1d6c 100644 --- a/gcc/ada/s-osinte-vxworks.ads +++ b/gcc/ada/s-osinte-vxworks.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -490,8 +490,6 @@ package System.OS_Interface is -- For uniprocessor systems return ERROR status. private - type sigset_t is new unsigned_long_long; - type pid_t is new int; ERROR_PID : constant pid_t := -1; @@ -499,4 +497,5 @@ private type clockid_t is new int; CLOCK_REALTIME : constant clockid_t := 0; + type sigset_t is new System.VxWorks.Ext.sigset_t; end System.OS_Interface; diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index 4480c693e8e..d85dd2efacf 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2010, 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- -- @@ -86,44 +86,74 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; use Ada.Calendar; +with Ada.Calendar; use Ada.Calendar; with Ada.Unchecked_Conversion; -with Interfaces; use Interfaces; + +with Interfaces; use Interfaces; use Ada; package body System.Random_Numbers is - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is very awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally, - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution is to use the heap and pointers, and, to avoid memory leaks, - -- controlled types. - - -- This is awfully heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - Low31_Mask : constant := 2**31-1; - Bit31_Mask : constant := 2**31; - - Matrix_A_X : constant array (State_Val range 0 .. 1) of State_Val := - (0, 16#9908b0df#); - Y2K : constant Calendar.Time := Calendar.Time_Of (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); - -- First Year 2000 day + -- First day of Year 2000 (what is this for???) + Image_Numeral_Length : constant := Max_Image_Width / N; subtype Image_String is String (1 .. Max_Image_Width); - -- Utility functions - - procedure Init (Gen : out Generator; Initiator : Unsigned_32); + ---------------------------- + -- Algorithmic Parameters -- + ---------------------------- + + Lower_Mask : constant := 2**31-1; + Upper_Mask : constant := 2**31; + + Matrix_A : constant array (State_Val range 0 .. 1) of State_Val + := (0, 16#9908b0df#); + -- The twist transformation is represented by a matrix of the form + -- + -- [ 0 I(31) ] + -- [ _a ] + -- + -- where 0 is a 31x31 block of 0s, I(31) is the 31x31 identity matrix and + -- _a is a particular bit row-vector, represented here by a 32-bit integer. + -- If integer x represents a row vector of bits (with x(0), the units bit, + -- last), then + -- x * A = [0 x(31..1)] xor Matrix_A(x(0)). + + U : constant := 11; + S : constant := 7; + B_Mask : constant := 16#9d2c5680#; + T : constant := 15; + C_Mask : constant := 16#efc60000#; + L : constant := 18; + -- The tempering shifts and bit masks, in the order applied + + Seed0 : constant := 5489; + -- Default seed, used to initialize the state vector when Reset not called + + Seed1 : constant := 19650218; + -- Seed used to initialize the state vector when calling Reset with an + -- initialization vector. + + Mult0 : constant := 1812433253; + -- Multiplier for a modified linear congruential generator used to + -- initialize the state vector when calling Reset with a single integer + -- seed. + + Mult1 : constant := 1664525; + Mult2 : constant := 1566083941; + -- Multipliers for two modified linear congruential generators used to + -- initialize the state vector when calling Reset with an initialization + -- vector. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Init (Gen : Generator; Initiator : Unsigned_32); -- Perform a default initialization of the state of Gen. The resulting -- state is identical for identical values of Initiator. @@ -147,75 +177,208 @@ package body System.Random_Numbers is ------------ function Random (Gen : Generator) return Unsigned_32 is - G : Generator renames Gen'Unrestricted_Access.all; + G : Generator renames Gen.Writable.Self.all; Y : State_Val; - I : Integer; + I : Integer; -- should avoid use of identifier I ??? begin I := G.I; if I < N - M then - Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask); - Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1); + Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); + Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); I := I + 1; elsif I < N - 1 then - Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask); + Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); Y := G.S (I + (M - N)) xor Shift_Right (Y, 1) - xor Matrix_A_X (Y and 1); + xor Matrix_A (Y and 1); I := I + 1; elsif I = N - 1 then - Y := (G.S (I) and Bit31_Mask) or (G.S (0) and Low31_Mask); - Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1); + Y := (G.S (I) and Upper_Mask) or (G.S (0) and Lower_Mask); + Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); I := 0; else - Init (G, 5489); + Init (G, Seed0); return Random (Gen); end if; G.S (G.I) := Y; G.I := I; - Y := Y xor Shift_Right (Y, 11); - Y := Y xor (Shift_Left (Y, 7) and 16#9d2c5680#); - Y := Y xor (Shift_Left (Y, 15) and 16#efc60000#); - Y := Y xor Shift_Right (Y, 18); + Y := Y xor Shift_Right (Y, U); + Y := Y xor (Shift_Left (Y, S) and B_Mask); + Y := Y xor (Shift_Left (Y, T) and C_Mask); + Y := Y xor Shift_Right (Y, L); return Y; end Random; - function Random (Gen : Generator) return Float is + generic + type Unsigned is mod <>; + type Real is digits <>; + with function Random (G : Generator) return Unsigned is <>; + function Random_Float_Template (Gen : Generator) return Real; + pragma Inline (Random_Float_Template); + -- Template for a random-number generator implementation that delivers + -- values of type Real in the range [0 .. 1], using values from Gen, + -- assuming that Unsigned is large enough to hold the bits of a mantissa + -- for type Real. + + --------------------------- + -- Random_Float_Template -- + --------------------------- - -- Note: The application of Float'Machine (...) is necessary to avoid - -- returning extra significand bits. Without it, the function's value - -- will change if it is spilled, for example, causing - -- gratuitous nondeterminism. + function Random_Float_Template (Gen : Generator) return Real is + + pragma Compile_Time_Error + (Unsigned'Last <= 2**(Real'Machine_Mantissa - 1), + "insufficiently large modular type used to hold mantissa"); - Result : constant Float := - Float'Machine - (Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-32)); begin - if Result < 1.0 then - return Result; + -- This code generates random floating-point numbers from unsigned + -- integers. Assuming that Real'Machine_Radix = 2, it can deliver all + -- machine values of type Real (as implied by Real'Machine_Mantissa and + -- Real'Machine_Emin), which is not true of the standard method (to + -- which we fall back for non-binary radix): computing Real(<random + -- integer>) / (<max random integer>+1). To do so, we first extract an + -- (M-1)-bit significand (where M is Real'Machine_Mantissa), and then + -- decide on a normalized exponent by repeated coin flips, decrementing + -- from 0 as long as we flip heads (1 bits). This process yields the + -- proper geometric distribution for the exponent: in a uniformly + -- distributed set of floating-point numbers, 1/2 of them will be in + -- (0.5, 1], 1/4 will be in (0.25, 0.5], and so forth. It makes a + -- further adjustment at binade boundaries (see comments below) to give + -- the effect of selecting a uniformly distributed real deviate in + -- [0..1] and then rounding to the nearest representable floating-point + -- number. The algorithm attempts to be stingy with random integers. In + -- the worst case, it can consume roughly -Real'Machine_Emin/32 32-bit + -- integers, but this case occurs with probability around + -- 2**Machine_Emin, and the expected number of calls to integer-valued + -- Random is 1. For another discussion of the issues addressed by this + -- process, see Allen Downey's unpublished paper at + -- http://allendowney.com/research/rand/downey07randfloat.pdf. + + if Real'Machine_Radix /= 2 then + return Real'Machine + (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); + else - return Float'Adjacent (1.0, 0.0); + declare + type Bit_Count is range 0 .. 4; + + subtype T is Real'Base; + + Trailing_Ones : constant array (Unsigned_32 range 0 .. 15) + of Bit_Count := + (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, + 2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3, + 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, + 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4); + + Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real + := (0 => 2.0**(0 - T'Machine_Mantissa), + 1 => 2.0**(-1 - T'Machine_Mantissa), + 2 => 2.0**(-2 - T'Machine_Mantissa), + 3 => 2.0**(-3 - T'Machine_Mantissa)); + + Extra_Bits : constant Natural := + (Unsigned'Size - T'Machine_Mantissa + 1); + -- Random bits left over after selecting mantissa + + Mantissa : Unsigned; + + X : Real; -- Scaled mantissa + R : Unsigned_32; -- Supply of random bits + R_Bits : Natural; -- Number of bits left in R + K : Bit_Count; -- Next decrement to exponent + + begin + Mantissa := Random (Gen) / 2**Extra_Bits; + R := Unsigned_32 (Mantissa mod 2**Extra_Bits); + R_Bits := Extra_Bits; + X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact + + if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then + + -- We got lucky and got a zero in our few extra bits + + K := Trailing_Ones (R); + + else + Find_Zero : loop + + -- R has R_Bits unprocessed random bits, a multiple of 4. + -- X needs to be halved for each trailing one bit. The + -- process stops as soon as a 0 bit is found. If R_Bits + -- becomes zero, reload R. + + -- Process 4 bits at a time for speed: the two iterations + -- on average with three tests each was still too slow, + -- probably because the branches are not predictable. + -- This loop now will only execute once 94% of the cases, + -- doing more bits at a time will not help. + + while R_Bits >= 4 loop + K := Trailing_Ones (R mod 16); + + exit Find_Zero when K < 4; -- Exits 94% of the time + + R_Bits := R_Bits - 4; + X := X / 16.0; + R := R / 16; + end loop; + + -- Do not allow us to loop endlessly even in the (very + -- unlikely) case that Random (Gen) keeps yielding all ones. + + exit Find_Zero when X = 0.0; + R := Random (Gen); + R_Bits := 32; + end loop Find_Zero; + end if; + + -- K has the count of trailing ones not reflected yet in X. The + -- following multiplication takes care of that, as well as the + -- correction to move the radix point to the left of the mantissa. + -- Doing it at the end avoids repeated rounding errors in the + -- exceedingly unlikely case of ever having a subnormal result. + + X := X * Pow_Tab (K); + + -- The smallest value in each binade is rounded to by 0.75 of + -- the span of real numbers as its next larger neighbor, and + -- 1.0 is rounded to by half of the span of real numbers as its + -- next smaller neighbor. To account for this, when we encounter + -- the smallest number in a binade, we substitute the smallest + -- value in the next larger binade with probability 1/2. + + if Mantissa = 0 and then Unsigned_32'(Random (Gen)) mod 2 = 0 then + X := 2.0 * X; + end if; + + return X; + end; end if; + end Random_Float_Template; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Float is + function F is new Random_Float_Template (Unsigned_32, Float); + begin + return F (Gen); end Random; function Random (Gen : Generator) return Long_Float is - Result : constant Long_Float := - Long_Float'Machine ((Long_Float (Unsigned_32'(Random (Gen))) - * 2.0 ** (-32)) - + (Long_Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-64))); + function F is new Random_Float_Template (Unsigned_64, Long_Float); begin - if Result < 1.0 then - return Result; - else - return Long_Float'Adjacent (1.0, 0.0); - end if; + return F (Gen); end Random; function Random (Gen : Generator) return Unsigned_64 is @@ -244,10 +407,10 @@ package body System.Random_Numbers is declare -- In the 64-bit case, we have to be careful, since not all 64-bit -- unsigned values are representable in GNAT's root_integer type. - -- Ignore different-size warnings here; since GNAT's handling + -- Ignore different-size warnings here since GNAT's handling -- is correct. - pragma Warnings ("Z"); + pragma Warnings ("Z"); -- better to use msg string! ??? function Conv_To_Unsigned is new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64); function Conv_To_Result is @@ -320,25 +483,30 @@ package body System.Random_Numbers is -- Reset -- ----------- - procedure Reset (Gen : out Generator) is - X : constant Unsigned_32 := Unsigned_32 ((Calendar.Clock - Y2K) * 64.0); + procedure Reset (Gen : Generator) is + Clock : constant Time := Calendar.Clock; + Duration_Since_Y2K : constant Duration := Clock - Y2K; + + X : constant Unsigned_32 := + Unsigned_32'Mod (Unsigned_64 (Duration_Since_Y2K) * 64); + begin Init (Gen, X); end Reset; - procedure Reset (Gen : out Generator; Initiator : Integer_32) is + procedure Reset (Gen : Generator; Initiator : Integer_32) is begin Init (Gen, To_Unsigned (Initiator)); end Reset; - procedure Reset (Gen : out Generator; Initiator : Unsigned_32) is + procedure Reset (Gen : Generator; Initiator : Unsigned_32) is begin Init (Gen, Initiator); end Reset; - procedure Reset (Gen : out Generator; Initiator : Integer) is + procedure Reset (Gen : Generator; Initiator : Integer) is begin - pragma Warnings ("C"); + pragma Warnings (Off, "condition is always *"); -- This is probably an unnecessary precaution against future change, but -- since the test is a static expression, no extra code is involved. @@ -358,30 +526,30 @@ package body System.Random_Numbers is end; end if; - pragma Warnings ("c"); + pragma Warnings (On, "condition is always *"); end Reset; - procedure Reset (Gen : out Generator; Initiator : Initialization_Vector) is + procedure Reset (Gen : Generator; Initiator : Initialization_Vector) is + G : Generator renames Gen.Writable.Self.all; I, J : Integer; begin - Init (Gen, 19650218); + Init (G, Seed1); I := 1; J := 0; if Initiator'Length > 0 then for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop - Gen.S (I) := - (Gen.S (I) - xor ((Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) - * 1664525)) + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult1)) + Initiator (J + Initiator'First) + Unsigned_32 (J); I := I + 1; J := J + 1; if I >= N then - Gen.S (0) := Gen.S (N - 1); + G.S (0) := G.S (N - 1); I := 1; end if; @@ -392,39 +560,42 @@ package body System.Random_Numbers is end if; for K in reverse 1 .. N - 1 loop - Gen.S (I) := - (Gen.S (I) xor ((Gen.S (I - 1) - xor Shift_Right (Gen.S (I - 1), 30)) * 1566083941)) + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult2)) - Unsigned_32 (I); I := I + 1; if I >= N then - Gen.S (0) := Gen.S (N - 1); + G.S (0) := G.S (N - 1); I := 1; end if; end loop; - Gen.S (0) := Bit31_Mask; + G.S (0) := Upper_Mask; end Reset; - procedure Reset (Gen : out Generator; From_State : Generator) is + procedure Reset (Gen : Generator; From_State : Generator) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.S := From_State.S; - Gen.I := From_State.I; + G.S := From_State.S; + G.I := From_State.I; end Reset; - procedure Reset (Gen : out Generator; From_State : State) is + procedure Reset (Gen : Generator; From_State : State) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.I := 0; - Gen.S := From_State; + G.I := 0; + G.S := From_State; end Reset; - procedure Reset (Gen : out Generator; From_Image : String) is + procedure Reset (Gen : Generator; From_Image : String) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.I := 0; + G.I := 0; for J in 0 .. N - 1 loop - Gen.S (J) := Extract_Value (From_Image, J); + G.S (J) := Extract_Value (From_Image, J); end loop; end Reset; @@ -468,7 +639,6 @@ package body System.Random_Numbers is begin Result := (others => ' '); - for J in 0 .. N - 1 loop Insert_Image (Result, J, Gen.S ((J + Gen.I) mod N)); end loop; @@ -493,18 +663,18 @@ package body System.Random_Numbers is -- Init -- ---------- - procedure Init (Gen : out Generator; Initiator : Unsigned_32) is + procedure Init (Gen : Generator; Initiator : Unsigned_32) is + G : Generator renames Gen.Writable.Self.all; begin - Gen.S (0) := Initiator; + G.S (0) := Initiator; for I in 1 .. N - 1 loop - Gen.S (I) := - 1812433253 - * (Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30)) + G.S (I) := + (G.S (I - 1) xor Shift_Right (G.S (I - 1), 30)) * Mult0 + Unsigned_32 (I); end loop; - Gen.I := 0; + G.I := 0; end Init; ------------------ @@ -526,9 +696,8 @@ package body System.Random_Numbers is ------------------- function Extract_Value (S : String; Index : Integer) return State_Val is + Start : constant Integer := S'First + Index * Image_Numeral_Length; begin - return State_Val'Value (S (S'First + Index * 11 .. - S'First + Index * 11 + 11)); + return State_Val'Value (S (Start .. Start + Image_Numeral_Length - 1)); end Extract_Value; - end System.Random_Numbers; diff --git a/gcc/ada/s-rannum.ads b/gcc/ada/s-rannum.ads index 28dcdc69215..0d2a7e9dee7 100644 --- a/gcc/ada/s-rannum.ads +++ b/gcc/ada/s-rannum.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007,2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2007-2010, 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- -- @@ -88,27 +88,27 @@ package System.Random_Numbers is -- in Reset). In general, there is little point in providing more than -- a certain number of values (currently 624). - procedure Reset (Gen : out Generator); + procedure Reset (Gen : Generator); -- Re-initialize the state of Gen from the time of day - procedure Reset (Gen : out Generator; Initiator : Initialization_Vector); - procedure Reset (Gen : out Generator; Initiator : Interfaces.Integer_32); - procedure Reset (Gen : out Generator; Initiator : Interfaces.Unsigned_32); - procedure Reset (Gen : out Generator; Initiator : Integer); + procedure Reset (Gen : Generator; Initiator : Initialization_Vector); + procedure Reset (Gen : Generator; Initiator : Interfaces.Integer_32); + procedure Reset (Gen : Generator; Initiator : Interfaces.Unsigned_32); + procedure Reset (Gen : Generator; Initiator : Integer); -- Re-initialize Gen based on the Initiator in various ways. Identical -- values of Initiator cause identical sequences of values. - procedure Reset (Gen : out Generator; From_State : Generator); + procedure Reset (Gen : Generator; From_State : Generator); -- Causes the state of Gen to be identical to that of From_State; Gen -- and From_State will produce identical sequences of values subsequently. - procedure Reset (Gen : out Generator; From_State : State); + procedure Reset (Gen : Generator; From_State : State); procedure Save (Gen : Generator; To_State : out State); -- The sequence -- Save (Gen2, S); Reset (Gen1, S) -- has the same effect as Reset (Gen2, Gen1). - procedure Reset (Gen : out Generator; From_Image : String); + procedure Reset (Gen : Generator; From_Image : String); function Image (Gen : Generator) return String; -- The call -- Reset (Gen2, Image (Gen1)) @@ -135,12 +135,19 @@ private subtype State_Val is Interfaces.Unsigned_32; type State is array (0 .. N - 1) of State_Val; + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + S : State := (others => 0); -- The shift register, a circular buffer I : Integer := N; - -- Current starting position in shift register S + -- Current starting position in shift register S (N means uninitialized) + -- We should avoid using the identifier I here ??? end record; end System.Random_Numbers; diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb index dec4c1fcef0..1c0cf746a53 100755 --- a/gcc/ada/s-regpat.adb +++ b/gcc/ada/s-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2009, AdaCore -- +-- Copyright (C) 1999-2010, 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- -- @@ -47,12 +47,10 @@ with Ada.Unchecked_Conversion; package body System.Regpat is - MAGIC : constant Character := Character'Val (10#0234#); - -- The first byte of the regexp internal "program" is actually - -- this magic number; the start node begins in the second byte. - -- - -- This is used to make sure that a regular expression was correctly - -- compiled. + Debug : constant Boolean := False; + -- Set to True to activate debug traces. This is normally set to constant + -- False to simply delete all the trace code. It is to be edited to True + -- for internal debugging of the package. ---------------------------- -- Implementation details -- @@ -76,21 +74,19 @@ package body System.Regpat is -- You can see the exact byte-compiled version by using the Dump -- subprogram. However, here are a few examples: - -- (a|b): 1 : MAGIC - -- 2 : BRANCH (next at 10) - -- 5 : EXACT (next at 18) operand=a - -- 10 : BRANCH (next at 18) - -- 13 : EXACT (next at 18) operand=b - -- 18 : EOP (next at 0) + -- (a|b): 1 : BRANCH (next at 9) + -- 4 : EXACT (next at 17) operand=a + -- 9 : BRANCH (next at 17) + -- 12 : EXACT (next at 17) operand=b + -- 17 : EOP (next at 0) -- - -- (ab)*: 1 : MAGIC - -- 2 : CURLYX (next at 26) { 0, 32767} - -- 9 : OPEN 1 (next at 13) - -- 13 : EXACT (next at 19) operand=ab - -- 19 : CLOSE 1 (next at 23) - -- 23 : WHILEM (next at 0) - -- 26 : NOTHING (next at 29) - -- 29 : EOP (next at 0) + -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767} + -- 8 : OPEN 1 (next at 12) + -- 12 : EXACT (next at 18) operand=ab + -- 18 : CLOSE 1 (next at 22) + -- 22 : WHILEM (next at 0) + -- 25 : NOTHING (next at 28) + -- 28 : EOP (next at 0) -- The opcodes are: @@ -186,6 +182,12 @@ package body System.Regpat is -- Using two bytes for the "next" pointer is vast overkill for most -- things, but allows patterns to get big without disasters. + Next_Pointer_Bytes : constant := 3; + -- Points after the "next pointer" data. An instruction is therefore: + -- 1 byte: instruction opcode + -- 2 bytes: pointer to next instruction + -- * bytes: optional data for the instruction + ----------------------- -- Character classes -- ----------------------- @@ -279,11 +281,6 @@ package body System.Regpat is Op : out Character_Class); -- Return a pointer to the string argument of the node at P - function Get_Next_Offset - (Program : Program_Data; - IP : Pointer) return Pointer; - -- Get the offset field of a node. Used by Get_Next - function Get_Next (Program : Program_Data; IP : Pointer) return Pointer; @@ -303,7 +300,6 @@ package body System.Regpat is pragma Inline (Is_Alnum); pragma Inline (Is_White_Space); pragma Inline (Get_Next); - pragma Inline (Get_Next_Offset); pragma Inline (Operand); pragma Inline (Read_Natural); pragma Inline (String_Length); @@ -318,6 +314,23 @@ package body System.Regpat is Worst_Expression : constant Expression_Flags := (others => False); -- Worst case + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True); + -- Dump the program until the node Till (not included) is met. Every line + -- is indented with Index spaces at the beginning Dumps till the end if + -- Till is 0. + + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural); + -- Same as above, but only dumps a single operation, and compute its + -- indentation from the program. + --------- -- "=" -- --------- @@ -340,7 +353,7 @@ package body System.Regpat is (Program_Data, Character_Class); begin - Op (0 .. 31) := Convert (Program (P + 3 .. P + 34)); + Op (0 .. 31) := Convert (Program (P + Next_Pointer_Bytes .. P + 34)); end Bitmap_Operand; ------------- @@ -369,7 +382,6 @@ package body System.Regpat is PM : Pattern_Matcher renames Matcher; Program : Program_Data renames PM.Program; - Emit_Code : constant Boolean := PM.Size > 0; Emit_Ptr : Pointer := Program_First; Parse_Pos : Natural := Expression'First; -- Input-scan pointer @@ -421,21 +433,31 @@ package body System.Regpat is (Expr_Flags : out Expression_Flags; IP : out Pointer); -- Parse_Atom is the lowest level parse procedure. - -- Optimization: gobbles an entire sequence of ordinary characters - -- so that it can turn them into a single node, which is smaller to - -- store and faster to run. Backslashed characters are exceptions, - -- each becoming a separate node; the code is simpler that way and - -- it's not worth fixing. + -- + -- Optimization: Gobbles an entire sequence of ordinary characters so + -- that it can turn them into a single node, which is smaller to store + -- and faster to run. Backslashed characters are exceptions, each + -- becoming a separate node; the code is simpler that way and it's + -- not worth fixing. procedure Insert_Operator (Op : Opcode; Operand : Pointer; Greedy : Boolean := True); - -- Insert_Operator inserts an operator in front of an - -- already-emitted operand and relocates the operand. - -- This applies to PLUS and STAR. + -- Insert_Operator inserts an operator in front of an already-emitted + -- operand and relocates the operand. This applies to PLUS and STAR. -- If Minmod is True, then the operator is non-greedy. + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer; + -- Insert an operator before Operand (and move the latter forward in the + -- program). Opsize is the size needed to represent the operator. This + -- returns the position at which the operator was inserted, and moves + -- Emit_Ptr after the new position of the operand. + procedure Insert_Curly_Operator (Op : Opcode; Min : Natural; @@ -451,9 +473,6 @@ package body System.Regpat is procedure Link_Operand_Tail (P, Val : Pointer); -- Link_Tail on operand of first argument; noop if operand-less - function Next_Instruction (P : Pointer) return Pointer; - -- Dig the "next" pointer out of a node - procedure Fail (M : String); pragma No_Return (Fail); -- Fail with a diagnostic message, if possible @@ -513,7 +532,7 @@ package body System.Regpat is procedure Emit (B : Character) is begin - if Emit_Code then + if Emit_Ptr <= PM.Size then Program (Emit_Ptr) := B; end if; @@ -531,7 +550,12 @@ package body System.Regpat is (Character_Class, Program31); begin - if Emit_Code then + -- What is the mysterious constant 31 here??? Can't it be expressed + -- symbolically (size of integer - 1 or some such???). In any case + -- it should be declared as a constant (and referenced presumably + -- as this constant + 1 below. + + if Emit_Ptr + 31 <= PM.Size then Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); end if; @@ -544,7 +568,7 @@ package body System.Regpat is procedure Emit_Natural (IP : Pointer; N : Natural) is begin - if Emit_Code then + if IP + 1 <= PM.Size then Program (IP + 1) := Character'Val (N / 256); Program (IP) := Character'Val (N mod 256); end if; @@ -558,13 +582,13 @@ package body System.Regpat is Result : constant Pointer := Emit_Ptr; begin - if Emit_Code then + if Emit_Ptr + 2 <= PM.Size then Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); Program (Emit_Ptr + 1) := ASCII.NUL; Program (Emit_Ptr + 2) := ASCII.NUL; end if; - Emit_Ptr := Emit_Ptr + 3; + Emit_Ptr := Emit_Ptr + Next_Pointer_Bytes; return Result; end Emit_Node; @@ -639,21 +663,38 @@ package body System.Regpat is Operand : Pointer; Greedy : Boolean := True) is - Dest : constant Pointer := Emit_Ptr; Old : Pointer; - Size : Pointer := 7; + begin + Old := Insert_Operator_Before (Op, Operand, Greedy, Opsize => 7); + Emit_Natural (Old + Next_Pointer_Bytes, Min); + Emit_Natural (Old + Next_Pointer_Bytes + 2, Max); + end Insert_Curly_Operator; + + ---------------------------- + -- Insert_Operator_Before -- + ---------------------------- + + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer + is + Dest : constant Pointer := Emit_Ptr; + Old : Pointer; + Size : Pointer := Opsize; begin - -- If the operand is not greedy, insert an extra operand before it + -- If not greedy, we have to emit another opcode first if not Greedy then - Size := Size + 3; + Size := Size + Next_Pointer_Bytes; end if; -- Move the operand in the byte-compilation, so that we can insert -- the operator before it. - if Emit_Code then + if Emit_Ptr + Size <= PM.Size then Program (Operand + Size .. Emit_Ptr + Size) := Program (Operand .. Emit_Ptr); end if; @@ -665,15 +706,13 @@ package body System.Regpat is if not Greedy then Old := Emit_Node (MINMOD); - Link_Tail (Old, Old + 3); + Link_Tail (Old, Old + Next_Pointer_Bytes); end if; Old := Emit_Node (Op); - Emit_Natural (Old + 3, Min); - Emit_Natural (Old + 5, Max); - Emit_Ptr := Dest + Size; - end Insert_Curly_Operator; + return Old; + end Insert_Operator_Before; --------------------- -- Insert_Operator -- @@ -684,40 +723,11 @@ package body System.Regpat is Operand : Pointer; Greedy : Boolean := True) is - Dest : constant Pointer := Emit_Ptr; - Old : Pointer; - Size : Pointer := 3; - Discard : Pointer; pragma Warnings (Off, Discard); - begin - -- If not greedy, we have to emit another opcode first - - if not Greedy then - Size := Size + 3; - end if; - - -- Move the operand in the byte-compilation, so that we can insert - -- the operator before it. - - if Emit_Code then - Program (Operand + Size .. Emit_Ptr + Size) := - Program (Operand .. Emit_Ptr); - end if; - - -- Insert the operator at the position previously occupied by the - -- operand. - - Emit_Ptr := Operand; - - if not Greedy then - Old := Emit_Node (MINMOD); - Link_Tail (Old, Old + 3); - end if; - - Discard := Emit_Node (Op); - Emit_Ptr := Dest + Size; + Discard := Insert_Operator_Before + (Op, Operand, Greedy, Opsize => Next_Pointer_Bytes); end Insert_Operator; ----------------------- @@ -784,7 +794,7 @@ package body System.Regpat is procedure Link_Operand_Tail (P, Val : Pointer) is begin - if Emit_Code and then Program (P) = BRANCH then + if P <= PM.Size and then Program (P) = BRANCH then Link_Tail (Operand (P), Val); end if; end Link_Operand_Tail; @@ -799,16 +809,13 @@ package body System.Regpat is Offset : Pointer; begin - if not Emit_Code then - return; - end if; - - -- Find last node + -- Find last node (the size of the pattern matcher might be too + -- small, so don't try to read past its end). Scan := P; - loop - Temp := Next_Instruction (Scan); - exit when Temp = 0; + while Scan + Next_Pointer_Bytes <= PM.Size loop + Temp := Get_Next (Program, Scan); + exit when Temp = Scan; Scan := Temp; end loop; @@ -817,47 +824,25 @@ package body System.Regpat is Emit_Natural (Scan + 1, Natural (Offset)); end Link_Tail; - ---------------------- - -- Next_Instruction -- - ---------------------- - - function Next_Instruction (P : Pointer) return Pointer is - Offset : Pointer; - - begin - if not Emit_Code then - return 0; - end if; - - Offset := Get_Next_Offset (Program, P); - - if Offset = 0 then - return 0; - end if; - - return P + Offset; - end Next_Instruction; - ----------- -- Parse -- ----------- - -- Combining parenthesis handling with the base level - -- of regular expression is a trifle forced, but the - -- need to tie the tails of the branches to what follows - -- makes it hard to avoid. + -- Combining parenthesis handling with the base level of regular + -- expression is a trifle forced, but the need to tie the tails of the + -- the branches to what follows makes it hard to avoid. procedure Parse - (Parenthesized : Boolean; - Flags : out Expression_Flags; - IP : out Pointer) + (Parenthesized : Boolean; + Flags : out Expression_Flags; + IP : out Pointer) is - E : String renames Expression; - Br : Pointer; - Ender : Pointer; - Par_No : Natural; - New_Flags : Expression_Flags; - Have_Branch : Boolean := False; + E : String renames Expression; + Br, Br2 : Pointer; + Ender : Pointer; + Par_No : Natural; + New_Flags : Expression_Flags; + Have_Branch : Boolean := False; begin Flags := (Has_Width => True, others => False); -- Tentatively @@ -938,15 +923,16 @@ package body System.Regpat is Link_Tail (IP, Ender); - if Have_Branch then + if Have_Branch and then Emit_Ptr <= PM.Size then -- Hook the tails of the branches to the closing node Br := IP; loop - exit when Br = 0; Link_Operand_Tail (Br, Ender); - Br := Next_Instruction (Br); + Br2 := Get_Next (Program, Br); + exit when Br2 = Br; + Br := Br2; end loop; end if; @@ -1639,13 +1625,13 @@ package body System.Regpat is -- is an initial string to emit, do it now. if Has_Special_Operator - and then Emit_Ptr >= Length_Ptr + 3 + and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes then Emit_Ptr := Emit_Ptr - 1; Parse_Pos := Start_Pos; end if; - if Emit_Code then + if Length_Ptr <= PM.Size then Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); end if; @@ -1987,7 +1973,6 @@ package body System.Regpat is -- Start of processing for Compile begin - Emit (MAGIC); Parse (False, Expr_Flags, Result); if Result = 0 then @@ -1999,7 +1984,7 @@ package body System.Regpat is -- Do we want to actually compile the expression, or simply get the -- code size ??? - if Emit_Code then + if Emit_Ptr <= PM.Size then Optimize (PM); end if; @@ -2010,19 +1995,38 @@ package body System.Regpat is (Expression : String; Flags : Regexp_Flags := No_Flags) return Pattern_Matcher is + -- Assume the compiled regexp will fit in 1000 chars. If it does not we + -- will have to compile a second time once the correct size is known. If + -- it fits, we save a significant amount of time by avoiding the second + -- compilation. + + Dummy : Pattern_Matcher (1000); Size : Program_Size; - Dummy : Pattern_Matcher (0); - pragma Unreferenced (Dummy); begin Compile (Dummy, Expression, Size, Flags); - declare - Result : Pattern_Matcher (Size); - begin - Compile (Result, Expression, Size, Flags); - return Result; - end; + if Size <= Dummy.Size then + return Pattern_Matcher' + (Size => Size, + First => Dummy.First, + Anchored => Dummy.Anchored, + Must_Have => Dummy.Must_Have, + Must_Have_Length => Dummy.Must_Have_Length, + Paren_Count => Dummy.Paren_Count, + Flags => Dummy.Flags, + Program => Dummy.Program + (Dummy.Program'First .. Dummy.Program'First + Size - 1)); + else + -- We have to recompile now that we know the size + -- ??? Can we use Ada05's return construct ? + declare + Result : Pattern_Matcher (Size); + begin + Compile (Result, Expression, Size, Flags); + return Result; + end; + end if; end Compile; procedure Compile @@ -2031,93 +2035,107 @@ package body System.Regpat is Flags : Regexp_Flags := No_Flags) is Size : Program_Size; - pragma Unreferenced (Size); + begin Compile (Matcher, Expression, Size, Flags); + + if Size > Matcher.Size then + raise Expression_Error with "Pattern_Matcher is too small"; + end if; end Compile; - ---------- - -- Dump -- - ---------- + -------------------- + -- Dump_Operation -- + -------------------- - procedure Dump (Self : Pattern_Matcher) is - Op : Opcode; - Program : Program_Data renames Self.Program; + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural) + is + Current : Pointer := Index; + begin + Dump_Until (Program, Current, Current + 1, Indent); + end Dump_Operation; + + ---------------- + -- Dump_Until -- + ---------------- + + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True) + is + function Image (S : String) return String; + -- Remove leading space - procedure Dump_Until - (Start : Pointer; - Till : Pointer; - Indent : Natural := 0); - -- Dump the program until the node Till (not included) is met. - -- Every line is indented with Index spaces at the beginning - -- Dumps till the end if Till is 0. + ----------- + -- Image -- + ----------- - ---------------- - -- Dump_Until -- - ---------------- + function Image (S : String) return String is + begin + if S (S'First) = ' ' then + return S (S'First + 1 .. S'Last); + else + return S; + end if; + end Image; - procedure Dump_Until - (Start : Pointer; - Till : Pointer; - Indent : Natural := 0) - is - Next : Pointer; - Index : Pointer; - Local_Indent : Natural := Indent; - Length : Pointer; + -- Local variables - begin - Index := Start; - while Index < Till loop - Op := Opcode'Val (Character'Pos ((Self.Program (Index)))); + Op : Opcode; + Next : Pointer; + Length : Pointer; + Local_Indent : Natural := Indent; - if Op = CLOSE then - Local_Indent := Local_Indent - 3; - end if; + -- Start of processing for Dump_Until - declare - Point : constant String := Pointer'Image (Index); + begin + while Index < Till loop + Op := Opcode'Val (Character'Pos ((Program (Index)))); + Next := Get_Next (Program, Index); + if Do_Print then + declare + Point : constant String := Pointer'Image (Index); begin - for J in 1 .. 6 - Point'Length loop - Put (' '); - end loop; - - Put (Point - & " : " - & (1 .. Local_Indent => ' ') - & Opcode'Image (Op)); + Put ((1 .. 4 - Point'Length => ' ') + & Point & ":" + & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op)); end; -- Print the parenthesis number if Op = OPEN or else Op = CLOSE or else Op = REFF then - Put (Natural'Image (Character'Pos (Program (Index + 3)))); + Put (Image (Natural'Image + (Character'Pos + (Program (Index + Next_Pointer_Bytes))))); end if; - Next := Index + Get_Next_Offset (Program, Index); - if Next = Index then - Put (" (next at 0)"); + Put (" (-)"); else - Put (" (next at " & Pointer'Image (Next) & ")"); + Put (" (" & Image (Pointer'Image (Next)) & ")"); end if; + end if; - case Op is - - -- Character class operand - - when ANYOF => null; - declare - Bitmap : Character_Class; - Last : Character := ASCII.NUL; - Current : Natural := 0; + case Op is + when ANYOF => + declare + Bitmap : Character_Class; + Last : Character := ASCII.NUL; + Current : Natural := 0; + Current_Char : Character; - Current_Char : Character; + begin + Bitmap_Operand (Program, Index, Bitmap); - begin - Bitmap_Operand (Program, Index, Bitmap); - Put (" operand="); + if Do_Print then + Put ("["); while Current <= 255 loop Current_Char := Character'Val (Current); @@ -2135,17 +2153,16 @@ package body System.Regpat is Current_Char := Character'Val (Current); exit when not Get_From_Class (Bitmap, Current_Char); - end loop; - if Last <= ' ' then + if not Is_Graphic (Last) then Put (Last'Img); else Put (Last); end if; if Character'Succ (Last) /= Current_Char then - Put ("-" & Character'Pred (Current_Char)); + Put ("\-" & Character'Pred (Current_Char)); end if; else @@ -2153,76 +2170,93 @@ package body System.Regpat is end if; end loop; - New_Line; - Index := Index + 3 + Bitmap'Length; - end; + Put_Line ("]"); + end if; - -- string operand + Index := Index + Next_Pointer_Bytes + Bitmap'Length; + end; - when EXACT | EXACTF => - Length := String_Length (Program, Index); - Put (" operand (length:" & Program_Size'Image (Length + 1) - & ") =" - & String (Program (String_Operand (Index) - .. String_Operand (Index) - + Length))); - Index := String_Operand (Index) + Length + 1; - New_Line; + when EXACT | EXACTF => + Length := String_Length (Program, Index); + if Do_Print then + Put (" (" & Image (Program_Size'Image (Length + 1)) + & " chars) <" + & String (Program (String_Operand (Index) + .. String_Operand (Index) + + Length))); + Put_Line (">"); + end if; - -- Node operand + Index := String_Operand (Index) + Length + 1; - when BRANCH => - New_Line; - Dump_Until (Index + 3, Next, Local_Indent + 3); - Index := Next; + -- Node operand - when STAR | PLUS => + when BRANCH | STAR | PLUS => + if Do_Print then New_Line; + end if; - -- Only one instruction + Index := Index + Next_Pointer_Bytes; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); + + when CURLY | CURLYX => + if Do_Print then + Put_Line + (" {" + & Image (Natural'Image + (Read_Natural (Program, Index + Next_Pointer_Bytes))) + & "," + & Image (Natural'Image (Read_Natural (Program, Index + 5))) + & "}"); + end if; - Dump_Until (Index + 3, Index + 4, Local_Indent + 3); - Index := Next; + Index := Index + 7; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); - when CURLY | CURLYX => - Put (" {" - & Natural'Image (Read_Natural (Program, Index + 3)) - & "," - & Natural'Image (Read_Natural (Program, Index + 5)) - & "}"); + when OPEN => + if Do_Print then New_Line; - Dump_Until (Index + 7, Next, Local_Indent + 3); - Index := Next; + end if; - when OPEN => - New_Line; - Index := Index + 4; - Local_Indent := Local_Indent + 3; + Index := Index + 4; + Local_Indent := Local_Indent + 1; - when CLOSE | REFF => + when CLOSE | REFF => + if Do_Print then New_Line; - Index := Index + 4; + end if; - when EOP => - Index := Index + 3; - New_Line; - exit; + Index := Index + 4; - -- No operand + if Op = CLOSE then + Local_Indent := Local_Indent - 1; + end if; - when others => - Index := Index + 3; + when others => + Index := Index + Next_Pointer_Bytes; + + if Do_Print then New_Line; - end case; - end loop; - end Dump_Until; + end if; + + exit when Op = EOP; + end case; + end loop; + end Dump_Until; + + ---------- + -- Dump -- + ---------- + + procedure Dump (Self : Pattern_Matcher) is + Program : Program_Data renames Self.Program; + Index : Pointer := Program'First; -- Start of processing for Dump begin - pragma Assert (Self.Program (Program_First) = MAGIC, - "Corrupted Pattern_Matcher"); - Put_Line ("Must start with (Self.First) = " & Character'Image (Self.First)); @@ -2238,8 +2272,7 @@ package body System.Regpat is Put_Line (" Multiple_Lines mode"); end if; - Put_Line (" 1 : MAGIC"); - Dump_Until (Program_First + 1, Self.Program'Last + 1); + Dump_Until (Program, Index, Self.Program'Last + 1, 0); end Dump; -------------------- @@ -2261,27 +2294,10 @@ package body System.Regpat is -------------- function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is - Offset : constant Pointer := Get_Next_Offset (Program, IP); begin - if Offset = 0 then - return 0; - else - return IP + Offset; - end if; + return IP + Pointer (Read_Natural (Program, IP + 1)); end Get_Next; - --------------------- - -- Get_Next_Offset -- - --------------------- - - function Get_Next_Offset - (Program : Program_Data; - IP : Pointer) return Pointer - is - begin - return Pointer (Read_Natural (Program, IP + 1)); - end Get_Next_Offset; - -------------- -- Is_Alnum -- -------------- @@ -2401,9 +2417,8 @@ package body System.Regpat is -- using a loop instead of recursion. -- Why is the above comment part of the spec rather than body ??? - function Match_Whilem (IP : Pointer) return Boolean; - -- Return True if a WHILEM matches - -- How come IP is unreferenced in the body ??? + function Match_Whilem return Boolean; + -- Return True if a WHILEM matches the Current_Curly function Recurse_Match (IP : Pointer; From : Natural) return Boolean; pragma Inline (Recurse_Match); @@ -2418,6 +2433,11 @@ package body System.Regpat is Greedy : Boolean) return Boolean; -- Return True it the simple operator (possibly non-greedy) matches + Dump_Indent : Integer := -1; + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True); + procedure Dump_Error (Msg : String); + -- Debug: print the current context + pragma Inline (Index); pragma Inline (Repeat); @@ -2446,15 +2466,15 @@ package body System.Regpat is ------------------- function Recurse_Match (IP : Pointer; From : Natural) return Boolean is - L : constant Natural := Last_Paren; - + L : constant Natural := Last_Paren; Tmp_F : constant Match_Array := Matches_Full (From + 1 .. Matches_Full'Last); - Start : constant Natural_Array := Matches_Tmp (From + 1 .. Matches_Tmp'Last); Input : constant Natural := Input_Pos; + Dump_Indent_Save : constant Integer := Dump_Indent; + begin if Match (IP) then return True; @@ -2464,9 +2484,45 @@ package body System.Regpat is Matches_Full (Tmp_F'Range) := Tmp_F; Matches_Tmp (Start'Range) := Start; Input_Pos := Input; + Dump_Indent := Dump_Indent_Save; return False; end Recurse_Match; + ------------------ + -- Dump_Current -- + ------------------ + + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is + Length : constant := 10; + Pos : constant String := Integer'Image (Input_Pos); + + begin + if Prefix then + Put ((1 .. 5 - Pos'Length => ' ')); + Put (Pos & " <" + & Data (Input_Pos + .. Integer'Min (Last_In_Data, Input_Pos + Length - 1))); + Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' ')); + Put ("> |"); + + else + Put (" "); + end if; + + Dump_Operation (Program, Scan, Indent => Dump_Indent); + end Dump_Current; + + ---------------- + -- Dump_Error -- + ---------------- + + procedure Dump_Error (Msg : String) is + begin + Put (" | "); + Put ((1 .. Dump_Indent * 2 => ' ')); + Put_Line (Msg); + end Dump_Error; + ----------- -- Match -- ----------- @@ -2475,8 +2531,11 @@ package body System.Regpat is Scan : Pointer := IP; Next : Pointer; Op : Opcode; + Result : Boolean; begin + Dump_Indent := Dump_Indent + 1; + State_Machine : loop pragma Assert (Scan /= 0); @@ -2485,13 +2544,18 @@ package body System.Regpat is Op := Opcode'Val (Character'Pos (Program (Scan))); - -- Calculate offset of next instruction. - -- Second character is most significant in Program_Data. + -- Calculate offset of next instruction. Second character is most + -- significant in Program_Data. Next := Get_Next (Program, Scan); + if Debug then + Dump_Current (Scan); + end if; + case Op is when EOP => + Dump_Indent := Dump_Indent - 1; return True; -- Success ! when BRANCH => @@ -2501,6 +2565,7 @@ package body System.Regpat is else loop if Recurse_Match (Operand (Scan), 0) then + Dump_Indent := Dump_Indent - 1; return True; end if; @@ -2517,7 +2582,7 @@ package body System.Regpat is when BOL => exit State_Machine when Input_Pos /= BOL_Pos and then ((Self.Flags and Multiple_Lines) = 0 - or else Data (Input_Pos - 1) /= ASCII.LF); + or else Data (Input_Pos - 1) /= ASCII.LF); when MBOL => exit State_Machine when Input_Pos /= BOL_Pos @@ -2529,7 +2594,7 @@ package body System.Regpat is when EOL => exit State_Machine when Input_Pos <= Data'Last and then ((Self.Flags and Multiple_Lines) = 0 - or else Data (Input_Pos) /= ASCII.LF); + or else Data (Input_Pos) /= ASCII.LF); when MEOL => exit State_Machine when Input_Pos <= Data'Last @@ -2610,7 +2675,6 @@ package body System.Regpat is declare Opnd : Pointer := String_Operand (Scan); Current : Positive := Input_Pos; - Last : constant Pointer := Opnd + String_Length (Program, Scan); @@ -2686,6 +2750,12 @@ package body System.Regpat is -- If we haven't seen that parenthesis yet if Last_Paren < No then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + return False; end if; @@ -2695,6 +2765,12 @@ package body System.Regpat is if Input_Pos > Last_In_Data or else Data (Input_Pos) /= Data (Data_Pos) then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + return False; end if; @@ -2711,7 +2787,9 @@ package body System.Regpat is Greed : constant Boolean := Greedy; begin Greedy := True; - return Match_Simple_Operator (Op, Scan, Next, Greed); + Result := Match_Simple_Operator (Op, Scan, Next, Greed); + Dump_Indent := Dump_Indent - 1; + return Result; end; when CURLYX => @@ -2725,9 +2803,10 @@ package body System.Regpat is declare Min : constant Natural := - Read_Natural (Program, Scan + 3); + Read_Natural (Program, Scan + Next_Pointer_Bytes); Max : constant Natural := - Read_Natural (Program, Scan + 5); + Read_Natural + (Program, Scan + Next_Pointer_Bytes + 2); Cc : aliased Current_Curly_Record; Has_Match : Boolean; @@ -2742,25 +2821,46 @@ package body System.Regpat is Next => Next, Lastloc => 0, Old_Cc => Current_Curly); + Greedy := True; Current_Curly := Cc'Unchecked_Access; - Has_Match := Match (Next - 3); + Has_Match := Match (Next - Next_Pointer_Bytes); -- Start on the WHILEM Current_Curly := Cc.Old_Cc; + Dump_Indent := Dump_Indent - 1; + + if not Has_Match then + if Debug then + Dump_Error ("CURLYX failed..."); + end if; + end if; + return Has_Match; end; when WHILEM => - return Match_Whilem (IP); + Result := Match_Whilem; + Dump_Indent := Dump_Indent - 1; + + if Debug and then not Result then + Dump_Error ("WHILEM: no match, backtracking"); + end if; + + return Result; end case; Scan := Next; end loop State_Machine; - -- If we get here, there is no match. - -- For successful matches when EOP is the terminating point. + if Debug then + Dump_Error ("failed..."); + Dump_Indent := Dump_Indent - 1; + end if; + + -- If we get here, there is no match. For successful matches when EOP + -- is the terminating point. return False; end Match; @@ -2786,8 +2886,8 @@ package body System.Regpat is Save : constant Natural := Input_Pos; begin - -- Lookahead to avoid useless match attempts - -- when we know what character comes next. + -- Lookahead to avoid useless match attempts when we know what + -- character comes next. if Program (Next) = EXACT then Next_Char := Program (String_Operand (Next)); @@ -2806,21 +2906,31 @@ package body System.Regpat is Operand_Code := Operand (Scan); when others => - Min := Read_Natural (Program, Scan + 3); - Max := Read_Natural (Program, Scan + 5); + Min := Read_Natural (Program, Scan + Next_Pointer_Bytes); + Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2); Operand_Code := Scan + 7; end case; + if Debug then + Dump_Current (Operand_Code, Prefix => False); + end if; + -- Non greedy operators if not Greedy then - -- Test the minimal repetitions + -- Test we can repeat at least Min times - if Min /= 0 - and then Repeat (Operand_Code, Min) < Min - then - return False; + if Min /= 0 then + No := Repeat (Operand_Code, Min); + + if No < Min then + if Debug then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; + + return False; + end if; end if; Old := Input_Pos; @@ -2828,6 +2938,7 @@ package body System.Regpat is -- Find the place where 'next' could work if Next_Char_Known then + -- Last position to check if Max = Natural'Last then @@ -2842,6 +2953,10 @@ package body System.Regpat is -- Look for the first possible opportunity + if Debug then + Dump_Error ("Next_Char must be " & Next_Char); + end if; + loop -- Find the next possible position @@ -2855,8 +2970,8 @@ package body System.Regpat is return False; end if; - -- Check that we still match if we stop - -- at the position we just found. + -- Check that we still match if we stop at the position we + -- just found. declare Num : constant Natural := Input_Pos - Old; @@ -2864,6 +2979,10 @@ package body System.Regpat is begin Input_Pos := Old; + if Debug then + Dump_Error ("Would we still match at that position?"); + end if; + if Repeat (Operand_Code, Num) < Num then return False; end if; @@ -2879,14 +2998,18 @@ package body System.Regpat is Input_Pos := Input_Pos + 1; end loop; - -- We know what the next character is + -- We do not know what the next character is else while Max >= Min loop + if Debug then + Dump_Error ("Non-greedy repeat, N=" & Min'Img); + Dump_Error ("Do we still match Next if we stop here?"); + end if; -- If the next character matches - if Match (Next) then + if Recurse_Match (Next, 1) then return True; end if; @@ -2897,6 +3020,10 @@ package body System.Regpat is if Repeat (Operand_Code, 1) /= 0 then Min := Min + 1; else + if Debug then + Dump_Error ("Non-greedy repeat failed..."); + end if; + return False; end if; end loop; @@ -2909,12 +3036,15 @@ package body System.Regpat is else No := Repeat (Operand_Code, Max); - -- ??? Perl has some special code here in case the - -- next instruction is of type EOL, since $ and \Z - -- can match before *and* after newline at the end. + if Debug and then No < Min then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; - -- ??? Perl has some special code here in case (paren) - -- is True. + -- ??? Perl has some special code here in case the next + -- instruction is of type EOL, since $ and \Z can match before + -- *and* after newline at the end. + + -- ??? Perl has some special code here in case (paren) is True -- Else, if we don't have any parenthesis @@ -2948,10 +3078,9 @@ package body System.Regpat is -- tree by recursing ever deeper. And if it fails, we have to reset -- our parent's current state that we can try again after backing off. - function Match_Whilem (IP : Pointer) return Boolean is - pragma Unreferenced (IP); - + function Match_Whilem return Boolean is Cc : constant Current_Curly_Access := Current_Curly; + N : constant Natural := Cc.Cur + 1; Ln : Natural := 0; @@ -2991,12 +3120,22 @@ package body System.Regpat is Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error + ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img); + end if; + if Match (Cc.Scan) then return True; end if; Cc.Cur := N - 1; Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + return False; end if; @@ -3022,6 +3161,9 @@ package body System.Regpat is -- Maximum greed exceeded ? if N >= Cc.Max then + if Debug then + Dump_Error ("failed..."); + end if; return False; end if; @@ -3029,6 +3171,10 @@ package body System.Regpat is Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error ("Next failed, what about Current?"); + end if; + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then return True; end if; @@ -3044,6 +3190,10 @@ package body System.Regpat is Cc.Cur := N; Cc.Lastloc := Input_Pos; + if Debug then + Dump_Error ("Recurse at current position"); + end if; + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then return True; end if; @@ -3057,6 +3207,10 @@ package body System.Regpat is Ln := Current_Curly.Cur; end if; + if Debug then + Dump_Error ("Failed matching for later positions"); + end if; + if Match (Cc.Next) then return True; end if; @@ -3068,6 +3222,11 @@ package body System.Regpat is Current_Curly := Cc; Cc.Cur := N - 1; Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + return False; end Match_Whilem; @@ -3200,7 +3359,7 @@ package body System.Regpat is Last_Paren := 0; Matches_Full := (others => No_Match); - if Match (Program_First + 1) then + if Match (Program_First) then Matches_Full (0) := (Pos, Input_Pos - 1); return True; end if; @@ -3218,12 +3377,6 @@ package body System.Regpat is return; end if; - -- Check validity of program - - pragma Assert - (Program (Program_First) = MAGIC, - "Corrupted Pattern_Matcher"); - -- If there is a "must appear" string, look for it if Self.Must_Have_Length > 0 then @@ -3430,7 +3583,7 @@ package body System.Regpat is function Operand (P : Pointer) return Pointer is begin - return P + 3; + return P + Next_Pointer_Bytes; end Operand; -------------- @@ -3452,7 +3605,7 @@ package body System.Regpat is Self.Must_Have := Program'Last + 1; Self.Must_Have_Length := 0; - Scan := Program_First + 1; -- First instruction (can be anything) + Scan := Program_First; -- First instruction (can be anything) if Program (Scan) = EXACT then Self.First := Program (String_Operand (Scan)); @@ -3547,7 +3700,7 @@ package body System.Regpat is is begin pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); - return Character'Pos (Program (P + 3)); + return Character'Pos (Program (P + Next_Pointer_Bytes)); end String_Length; -------------------- diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb index 7038d796c28..783fdc4a95d 100644 --- a/gcc/ada/s-shasto.adb +++ b/gcc/ada/s-shasto.adb @@ -6,8 +6,8 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- --- -- +-- Copyright (C) 1998-2010, 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- -- @@ -88,8 +88,8 @@ package body System.Shared_Storage is Item : AS.Stream_Element_Array); subtype Hash_Header is Natural range 0 .. 30; - -- Number of hash headers, related (for efficiency purposes only) - -- to the maximum number of lock files.. + -- Number of hash headers, related (for efficiency purposes only) to the + -- maximum number of lock files. type Shared_Var_File_Entry; type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; diff --git a/gcc/ada/s-stchop.adb b/gcc/ada/s-stchop.adb index d4aa675a857..b757c56532b 100644 --- a/gcc/ada/s-stchop.adb +++ b/gcc/ada/s-stchop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -48,28 +48,24 @@ package body System.Stack_Checking.Operations is function Set_Stack_Info (Stack : not null access Stack_Access) return Stack_Access; - -- The function Set_Stack_Info is the actual function that updates the -- cache containing a pointer to the Stack_Info. It may also be used for -- detecting asynchronous abort in combination with Invalidate_Self_Cache. - + -- -- Set_Stack_Info should do the following things in order: -- 1) Get the Stack_Access value for the current task -- 2) Set Stack.all to the value obtained in 1) -- 3) Optionally Poll to check for asynchronous abort - + -- -- This order is important because if at any time a write to the stack -- cache is pending, that write should be followed by a Poll to prevent -- loosing signals. - + -- -- Note: This function must be compiled with Polling turned off - - -- Note: on systems like VxWorks and OS/2 with real thread-local storage, - -- Set_Stack_Info should return an access value for such local - -- storage. In those cases the cache will always be up-to-date. - - -- The following constants should be imported from some system-specific - -- constants package. The constants must be static for performance reasons. + -- + -- Note: on systems with real thread-local storage, Set_Stack_Info should + -- return an access value for such local storage. In those cases the cache + -- will always be up-to-date. ---------------------------- -- Invalidate_Stack_Cache -- diff --git a/gcc/ada/s-stoele.adb b/gcc/ada/s-stoele.adb index 776aacb9426..cd3e22ef907 100644 --- a/gcc/ada/s-stoele.adb +++ b/gcc/ada/s-stoele.adb @@ -39,7 +39,7 @@ package body System.Storage_Elements is -- Conversion to/from address - -- Note qualification below of To_Address to avoid ambiguities on VMS. + -- Note qualification below of To_Address to avoid ambiguities on VMS function To_Address is new Ada.Unchecked_Conversion (Storage_Offset, Address); @@ -51,18 +51,30 @@ package body System.Storage_Elements is -- These functions must be place first because they are inlined_always -- and are used and inlined in other subprograms defined in this unit. - function To_Integer (Value : Address) return Integer_Address is - begin - return Integer_Address (Value); - end To_Integer; + ---------------- + -- To_Address -- + ---------------- function To_Address (Value : Integer_Address) return Address is begin return Address (Value); end To_Address; + ---------------- + -- To_Integer -- + ---------------- + + function To_Integer (Value : Address) return Integer_Address is + begin + return Integer_Address (Value); + end To_Integer; + -- Address arithmetic + --------- + -- "+" -- + --------- + function "+" (Left : Address; Right : Storage_Offset) return Address is begin return Storage_Elements.To_Address @@ -75,6 +87,10 @@ package body System.Storage_Elements is (To_Integer (To_Address (Left)) + To_Integer (Right)); end "+"; + --------- + -- "-" -- + --------- + function "-" (Left : Address; Right : Storage_Offset) return Address is begin return Storage_Elements.To_Address @@ -87,6 +103,10 @@ package body System.Storage_Elements is (To_Integer (Left) - To_Integer (Right))); end "-"; + ----------- + -- "mod" -- + ----------- + function "mod" (Left : Address; Right : Storage_Offset) return Storage_Offset @@ -106,4 +126,5 @@ package body System.Storage_Elements is raise Constraint_Error; end if; end "mod"; + end System.Storage_Elements; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 4cde338bfd3..2cf8131755b 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -99,10 +99,6 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - function Get_Policy (Prio : System.Any_Priority) return Character; - pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); - -- Get priority specific dispatching policy - Mutex_Protocol : Priority_Type; Foreign_Task_Elaborated : aliased Boolean := True; @@ -734,20 +730,13 @@ package body System.Task_Primitives.Operations is -- Set_Priority -- ------------------ - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for each - -- priority. Note that we assume that we are on a single processor with - -- run-till-blocked scheduling. - procedure Set_Priority (T : Task_Id; Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is - Array_Item : Integer; + pragma Unreferenced (Loss_Of_Inheritance); + Result : int; begin @@ -756,33 +745,16 @@ package body System.Task_Primitives.Operations is (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); - if (Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F') - and then Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - -- Annex D requirement (RM D.2.2(9)): - - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. + -- Note: in VxWorks 6.6 (or earlier), the task is placed at the end of + -- the priority queue instead of the head. This is not the behavior + -- required by Annex D (RM D.2.3(5/2)), but we consider it an acceptable + -- variation (RM 1.1.3(6)), given this is the built-in behavior of the + -- operating system. VxWorks versions starting from 6.7 implement the + -- required Annex D semantics. - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Give some processes a chance to arrive - - taskDelay (0); - - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; + -- In older versions we attempted to better approximate the Annex D + -- required behavior, but this simulation was not entirely accurate, + -- and it seems better to live with the standard VxWorks semantics. T.Common.Current_Priority := Prio; end Set_Priority; diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb index 9fb0cd6e798..ccc81d9d53b 100644 --- a/gcc/ada/s-tasdeb.adb +++ b/gcc/ada/s-tasdeb.adb @@ -362,10 +362,11 @@ package body System.Tasking.Debug is ----------- procedure Write (Fd : Integer; S : String; Count : Integer) is - Discard : Integer; + Discard : System.CRTL.ssize_t; pragma Unreferenced (Discard); begin - Discard := System.CRTL.write (Fd, S (S'First)'Address, Count); + Discard := System.CRTL.write (Fd, S (S'First)'Address, + System.CRTL.size_t (Count)); -- Is it really right to ignore write errors here ??? end Write; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index 4694310ebff..ba2bf6c267a 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -226,12 +226,12 @@ package body System.Tasking.Protected_Objects.Entries is raise Program_Error; end if; - -- pragma Assert (Self_Id.Deferral_Level = 0); -- If a PO is created from a controlled operation, abort is already - -- deferred at this point, so we need to use Defer_Abort_Nestable - -- In some cases, the above assertion can be useful to spot - -- inconsistencies, outside the above scenario involving controlled - -- types. + -- deferred at this point, so we need to use Defer_Abort_Nestable. In + -- some cases, the following assertion can help to spot inconsistencies, + -- outside the above scenario involving controlled types. + + -- pragma Assert (Self_Id.Deferral_Level = 0); Initialization.Defer_Abort_Nestable (Self_ID); Initialize_Lock (Init_Priority, Object.L'Access); diff --git a/gcc/ada/s-vxwext-kernel.ads b/gcc/ada/s-vxwext-kernel.ads index e450285ecbc..0df9211a68f 100644 --- a/gcc/ada/s-vxwext-kernel.ads +++ b/gcc/ada/s-vxwext-kernel.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,8 @@ package System.VxWorks.Ext is subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Long_Long_Integer'Size; + type t_id is new Long_Integer; subtype int is Interfaces.C.int; diff --git a/gcc/ada/s-vxwext-rtp.ads b/gcc/ada/s-vxwext-rtp.ads index 22452a18e77..844d39415db 100644 --- a/gcc/ada/s-vxwext-rtp.ads +++ b/gcc/ada/s-vxwext-rtp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,6 +39,8 @@ package System.VxWorks.Ext is subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Long_Long_Integer'Size; + type t_id is new Long_Integer; subtype int is Interfaces.C.int; diff --git a/gcc/ada/s-vxwext.ads b/gcc/ada/s-vxwext.ads index 42abdc1f355..1559d7d8e14 100644 --- a/gcc/ada/s-vxwext.ads +++ b/gcc/ada/s-vxwext.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2010, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,7 +39,10 @@ package System.VxWorks.Ext is subtype SEM_ID is Long_Integer; -- typedef struct semaphore *SEM_ID; + type sigset_t is mod 2 ** Interfaces.C.long'Size; + type t_id is new Long_Integer; + subtype int is Interfaces.C.int; type Interrupt_Handler is access procedure (parameter : System.Address); diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb new file mode 100644 index 00000000000..4591d8ef287 --- /dev/null +++ b/gcc/ada/scil_ll.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C I L _ L L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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; use Alloc; +with Atree; use Atree; +with Opt; use Opt; +with Sinfo; use Sinfo; +with Table; + +package body SCIL_LL is + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id); + -- Copy the SCIL field from Source to Target (it is used as the argument + -- for a call to Set_Reporting_Proc in package atree). + + function SCIL_Nodes_Table_Size return Pos; + -- Used to initialize the table of SCIL nodes because we do not want + -- to consume memory for this table if it is not required. + + ---------------------------- + -- SCIL_Nodes_Table_Size -- + ---------------------------- + + function SCIL_Nodes_Table_Size return Pos is + begin + if Generate_SCIL then + return Alloc.Orig_Nodes_Initial; + else + return 1; + end if; + end SCIL_Nodes_Table_Size; + + package SCIL_Nodes is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Node_Id'Base, + Table_Low_Bound => First_Node_Id, + Table_Initial => SCIL_Nodes_Table_Size, + Table_Increment => Alloc.Orig_Nodes_Increment, + Table_Name => "SCIL_Nodes"); + -- This table records the value of attribute SCIL_Node of all the + -- tree nodes. + + -------------------- + -- Copy_SCIL_Node -- + -------------------- + + procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is + begin + Set_SCIL_Node (Target, Get_SCIL_Node (Source)); + end Copy_SCIL_Node; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + SCIL_Nodes.Init; + Set_Reporting_Proc (Copy_SCIL_Node'Access); + end Initialize; + + ------------------- + -- Get_SCIL_Node -- + ------------------- + + function Get_SCIL_Node (N : Node_Id) return Node_Id is + begin + if Generate_SCIL + and then Present (N) + then + return SCIL_Nodes.Table (N); + else + return Empty; + end if; + end Get_SCIL_Node; + + ------------------- + -- Set_SCIL_Node -- + ------------------- + + procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is + begin + pragma Assert (Generate_SCIL); + + if Present (Value) then + case Nkind (Value) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; + + when N_SCIL_Dispatching_Call => + pragma Assert (Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement)); + null; + + when N_SCIL_Membership_Test => + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions)); + null; + + when others => + pragma Assert (False); + raise Program_Error; + end case; + end if; + + if Atree.Last_Node_Id > SCIL_Nodes.Last then + SCIL_Nodes.Set_Last (Atree.Last_Node_Id); + end if; + + SCIL_Nodes.Set_Item (N, Value); + end Set_SCIL_Node; + +end SCIL_LL; diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads new file mode 100644 index 00000000000..8265a19df30 --- /dev/null +++ b/gcc/ada/scil_ll.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S C I L _ L L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 extends the tree nodes with a field that is used to reference +-- the SCIL node. + +with Types; use Types; + +package SCIL_LL is + + function Get_SCIL_Node (N : Node_Id) return Node_Id; + -- Read the value of attribute SCIL node + + 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 + +end SCIL_LL; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index af1f3bbc3a0..d4005b47989 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,9 +37,12 @@ with Uintp; use Uintp; with Urealp; use Urealp; with Widechar; use Widechar; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.CRC32; with System.UTF_32; use System.UTF_32; with System.WCh_Con; use System.WCh_Con; +pragma Warnings (On); package body Scng is @@ -325,7 +328,8 @@ package body Scng is and then Source (Scan_Ptr + 2) = C then Scan_Ptr := Scan_Ptr + 1; - Error_Msg_S ("no space allowed here"); + Error_Msg_S -- CODEFIX + ("no space allowed here"); Scan_Ptr := Scan_Ptr + 2; return True; @@ -380,16 +384,14 @@ package body Scng is Error_Msg_S -- CODEFIX ("two consecutive underlines not permitted"); else - Error_Msg_S -- CODEFIX??? - ("underline cannot follow punctuation character"); + Error_Msg_S ("underline cannot follow punctuation character"); end if; else if Source (Scan_Ptr - 1) = '_' then - Error_Msg_S -- CODEFIX??? - ("punctuation character cannot follow underline"); + Error_Msg_S ("punctuation character cannot follow underline"); else - Error_Msg_S -- CODEFIX??? + Error_Msg_S ("two consecutive punctuation characters not permitted"); end if; end if; @@ -572,8 +574,7 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S ("use of "":"" is an obsolescent feature (RM J.2(3))?"); - Error_Msg_S - ("\use ""'#"" instead?"); + Error_Msg_S ("\use ""'#"" instead?"); end if; end if; @@ -658,9 +659,11 @@ package body Scng is elsif not Identifier_Char (C) then if Base_Char = '#' then - Error_Msg_S ("missing '#"); + Error_Msg_S -- CODEFIX + ("missing '#"); else - Error_Msg_S ("missing ':"); + Error_Msg_S -- CODEFIX + ("missing ':"); end if; exit; @@ -875,7 +878,7 @@ package body Scng is end if; end if; - Error_Msg_S -- CODEFIX + Error_Msg_S -- CODEFIX ("missing string quote"); end Error_Unterminated_String; @@ -1215,7 +1218,8 @@ package body Scng is Accumulate_Checksum ('&'); if Source (Scan_Ptr + 1) = '&' then - Error_Msg_S ("'&'& should be `AND THEN`"); + Error_Msg_S -- CODEFIX + ("'&'& should be `AND THEN`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_And; return; @@ -1263,7 +1267,8 @@ package body Scng is and then Source (Scan_Ptr + 2) /= '-' then Token := Tok_Colon_Equal; - Error_Msg (":- should be :=", Scan_Ptr); + Error_Msg -- CODEFIX + (":- should be :=", Scan_Ptr); Scan_Ptr := Scan_Ptr + 2; return; @@ -1367,7 +1372,8 @@ package body Scng is return; elsif Source (Scan_Ptr + 1) = '=' then - Error_Msg_S ("== should be ="); + Error_Msg_S -- CODEFIX + ("== should be ="); Scan_Ptr := Scan_Ptr + 1; end if; @@ -1588,8 +1594,7 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S ("use of ""'%"" is an obsolescent feature (RM J.2(4))?"); - Error_Msg_S - ("\use """""" instead?"); + Error_Msg_S ("\use """""" instead?"); end if; Slit; @@ -1669,13 +1674,13 @@ package body Scng is elsif Ada_Version >= Ada_05 and then Is_UTF_32_Non_Graphic (UTF_32 (Code)) then - Error_Msg + Error_Msg -- CODEFIX???? ("(Ada 2005) non-graphic character not permitted " & "in character literal", Wptr); end if; if Source (Scan_Ptr) /= ''' then - Error_Msg_S ("missing apostrophe"); + Error_Msg_S ("missing apostrophe"); else Scan_Ptr := Scan_Ptr + 1; end if; @@ -1789,7 +1794,8 @@ package body Scng is -- Special check for || to give nice message if Source (Scan_Ptr + 1) = '|' then - Error_Msg_S ("""'|'|"" should be `OR ELSE`"); + Error_Msg_S -- CODEFIX + ("""'|'|"" should be `OR ELSE`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; @@ -1815,12 +1821,12 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S ("use of ""'!"" is an obsolescent feature (RM J.2(2))?"); - Error_Msg_S - ("\use ""'|"" instead?"); + Error_Msg_S ("\use ""'|"" instead?"); end if; if Source (Scan_Ptr + 1) = '=' then - Error_Msg_S ("'!= should be /="); + Error_Msg_S -- CODEFIX + ("'!= should be /="); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Not_Equal; return; @@ -2068,8 +2074,7 @@ package body Scng is -- Punctuation is an error (at start of identifier) elsif Is_UTF_32_Punctuation (Cat) then - Error_Msg - ("identifier cannot start with punctuation", Wptr); + Error_Msg ("identifier cannot start with punctuation", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; @@ -2078,8 +2083,7 @@ package body Scng is -- Mark character is an error (at start of identifier) elsif Is_UTF_32_Mark (Cat) then - Error_Msg - ("identifier cannot start with mark character", Wptr); + Error_Msg ("identifier cannot start with mark character", Wptr); Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 19804e4567b..7111287c0a6 100644 --- a/gcc/ada/scos.ads +++ b/gcc/ada/scos.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, 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- -- @@ -148,21 +148,27 @@ package SCOs is -- o object declaration -- r renaming declaration -- i generic instantiation - -- C CASE statement (includes only the expression) + -- C CASE statement (from CASE through end of expression) -- E EXIT statement - -- F FOR loop statement (includes only the iteration scheme) - -- I IF statement (includes only the condition [in the RM sense, which - -- is a decision in the SCO sense]) + -- F FOR loop statement (from FOR through end of iteration scheme) + -- I IF statement (from IF through end of condition) -- P PRAGMA -- R extended RETURN statement - -- W WHILE loop statement (includes only the condition) + -- W WHILE loop statement (from WHILE through end of condition) + + -- Note: for I and W, condition above is in the RM syntax sense (this + -- condition is a decision in SCO terminology). -- and is omitted for all other cases. + -- Note: up to 6 entries can appear on a single CS line. If more than 6 + -- entries appear in one logical statement sequence, continuation lines + -- are marked by Cs and appear immediately after the CS line. + -- Decisions -- Note: in the following description, logical operator includes only the - -- short circuited forms and NOT (so can be only NOT, AND THEN, OR ELSE). + -- short-circuited forms and NOT (so can be only NOT, AND THEN, OR ELSE). -- The reason that we can exclude AND/OR/XOR is that we expect SCO's to -- be generated using the restriction No_Direct_Boolean_Operators if we -- are interested in decision coverage, which does not permit the use of @@ -171,18 +177,27 @@ package SCOs is -- we are generating SCO's only for simple coverage, then we are not -- interested in decisions in any case. - -- Decisions are either simple or complex. A simple decision is a boolean - -- expresssion that occurs in the context of a control structure in the - -- source program, including WHILE, IF, EXIT WHEN, or in an Assert, - -- Check, Pre_Condition or Post_Condition pragma. For pragmas, decision - -- SCOs are generated only if the corresponding pragma is enabled. Note - -- that a boolean expression in any other context, for example as right - -- hand side of an assignment, is not considered to be a simple decision. + -- Note: the reason we include NOT is for informational purposes. The + -- presence of NOT does not generate additional coverage obligations, + -- but if we know where the NOT's are, the coverage tool can generate + -- more accurate diagnostics on uncovered tests. + + -- A top level boolean expression is a boolean expression that is not an + -- operand of a logical operator. - -- A complex decision is an occurrence of a logical operator which is not - -- itself an operand of some other logical operator. If any operand of - -- the logical operator is itself a logical operator, this is not a - -- separate decision, it is part of the same decision. + -- Decisions are either simple or complex. A simple decision is a top + -- level boolean expresssion that has only one condition and that occurs + -- in the context of a control structure in the source program, including + -- WHILE, IF, EXIT WHEN, or in an Assert, Check, Pre_Condition or + -- Post_Condition pragma. For pragmas, decision SCOs are generated only + -- if the corresponding pragma is enabled. Note that a top level boolean + -- expression with only one condition that occurs in any other context, + -- for example as right hand side of an assignment, is not considered to + -- be a (simple) decision. + + -- A complex decision is a top level boolean expression that has more + -- than one condition. A complex decision may occur in any boolean + -- expression context. -- So for example, if we have @@ -201,7 +216,7 @@ package SCOs is -- For each decision, a decision line is generated with the form: - -- C*sloc expression + -- C* sloc expression -- Here * is one of the following characters: @@ -217,7 +232,7 @@ package SCOs is -- For X, sloc is omitted. -- The expression is a prefix polish form indicating the structure of - -- the decision, including logical operators and short circuit forms. + -- the decision, including logical operators and short-circuit forms. -- The following is a grammar showing the structure of expression: -- expression ::= term (if expr is not logical operator) @@ -248,8 +263,35 @@ package SCOs is -- ! indicates NOT applied to the expression. - -- In the context of Couverture, the No_Direct_Boolean_Opeartors - -- restriction is assumed, and no other operator can appear. + -- Note that complex decisions do NOT include non-short-circuited logical + -- operators (AND/XOR/OR). In the context of existing coverage tools the + -- No_Direct_Boolean_Operators restriction is assumed, so these operators + -- cannot appear in the source in any case. + + -- The SCO line for a decision always occurs after the CS line for the + -- enclosing statement. The SCO line for a nested decision always occurs + -- after the line for the enclosing decision. + + -- Note that membership tests are considered to be a single simple + -- condition, and that is true even if the Ada 2005 set membership + -- form is used, e.g. A in (2,7,11.15). + + -- Case Expressions + + -- For case statements, we rely on statement coverage to make sure that + -- all branches of a case statement are covered, but that does not work + -- for case expressions, since the entire expression is contained in a + -- single statement. However, for complete coverage we really should be + -- able to check that every branch of the case statement is covered, so + -- we generate a SCO of the form: + + -- CC sloc-range sloc-range ... + + -- where sloc-range covers the range of the case expression. + + -- Note: up to 6 entries can appear on a single CC line. If more than 6 + -- entries appear in one logical statement sequence, continuation lines + -- are marked by Cc and appear immediately after the CC line. --------------------------------------------------------------------- -- Internal table used to store Source Coverage Obligations (SCOs) -- @@ -289,19 +331,45 @@ package SCOs is -- Note: successive statements (possibly interspersed with entries of -- other kinds, that are ignored for this purpose), starting with one -- labeled with C1 = 'S', up to and including the first one labeled with - -- Last=True, indicate the sequence to be output for a sequence of - -- statements on a single CS line. + -- Last = True, indicate the sequence to be output for a sequence of + -- statements on a single CS line (possibly followed by Cs continuation + -- lines). + + -- Decision (IF/EXIT/WHILE) + -- C1 = 'I'/'E'/'W' (for IF/EXIT/WHILE) + -- C2 = ' ' + -- From = IF/EXIT/WHILE token + -- To = No_Source_Location + -- Last = unused + + -- Decision (PRAGMA) + -- C1 = 'P' + -- C2 = 'e'/'d' for enabled/disabled + -- From = PRAGMA token + -- To = No_Source_Location + -- Last = unused - -- Decision - -- C1 = decision type code + -- Note: when the parse tree is first scanned, we unconditionally build + -- a pragma decision entry for any decision in a pragma (here as always + -- in SCO contexts, the only pragmas with decisions are Assert, Check, + -- Precondition and Postcondition), and we mark the pragma as disabled. + -- + -- During analysis, if the pragma is enabled, Set_SCO_Pragma_Enabled to + -- mark the SCO decision table entry as enabled (C2 set to 'e'). Then + -- in Put_SCOs, we only output the decision for a pragma if C2 is 'e'. + -- + -- When we read SCOs from an ALI file (in Get_SCOs), we always set C2 + -- to 'e', since clearly the pragma is enabled if it was written out. + + -- Decision (Expression) + -- C1 = 'X' -- C2 = ' ' - -- From = location of IF/EXIT/PRAGMA/WHILE token, - -- No_Source_Location for X + -- From = No_Source_Location -- To = No_Source_Location -- Last = unused -- Operator - -- C1 = '!', '^', '&', '|' + -- C1 = '!', '&', '|' -- C2 = ' ' -- From = location of NOT/AND/OR token -- To = No_Source_Location @@ -316,8 +384,7 @@ package SCOs is -- Note: the sequence starting with a decision, and continuing with -- operators and elements up to and including the first one labeled with - -- Last = True, indicate the sequence to be output for a complex decision - -- on a single CD decision line. + -- Last = True, indicate the sequence to be output on one decision line. ---------------- -- Unit Table -- diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 8d3ca2a49fe..5e6d8b2766a 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -67,9 +67,9 @@ package body Sem is -- Controls debugging printouts for Walk_Library_Items Outer_Generic_Scope : Entity_Id := Empty; - -- Global reference to the outer scope that is generic. In a non - -- generic context, it is empty. At the moment, it is only used - -- for avoiding freezing of external references in generics. + -- Global reference to the outer scope that is generic. In a non- generic + -- context, it is empty. At the moment, it is only used for avoiding + -- freezing of external references in generics. Comp_Unit_List : Elist_Id := No_Elist; -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes @@ -80,9 +80,9 @@ package body Sem is generic with procedure Action (Withed_Unit : Node_Id); procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); - -- Walk all the with clauses of CU, and call Action for the with'ed - -- unit. Ignore limited withs, unless Include_Limited is True. - -- CU must be an N_Compilation_Unit. + -- Walk all the with clauses of CU, and call Action for the with'ed unit. + -- Ignore limited withs, unless Include_Limited is True. CU must be an + -- N_Compilation_Unit. generic with procedure Action (Withed_Unit : Node_Id); @@ -158,6 +158,9 @@ package body Sem is when N_Block_Statement => Analyze_Block_Statement (N); + when N_Case_Expression => + Analyze_Case_Expression (N); + when N_Case_Statement => Analyze_Case_Statement (N); @@ -221,6 +224,9 @@ package body Sem is when N_Explicit_Dereference => Analyze_Explicit_Dereference (N); + when N_Expression_With_Actions => + Analyze_Expression_With_Actions (N); + when N_Extended_Return_Statement => Analyze_Extended_Return_Statement (N); @@ -576,14 +582,14 @@ package body Sem is when N_With_Clause => Analyze_With_Clause (N); - -- A call to analyze the Empty node is an error, but most likely - -- it is an error caused by an attempt to analyze a malformed - -- piece of tree caused by some other error, so if there have - -- been any other errors, we just ignore it, otherwise it is - -- a real internal error which we complain about. + -- A call to analyze the Empty node is an error, but most likely it + -- is an error caused by an attempt to analyze a malformed piece of + -- tree caused by some other error, so if there have been any other + -- errors, we just ignore it, otherwise it is a real internal error + -- which we complain about. - -- We must also consider the case of call to a runtime function - -- that is not available in the configurable runtime. + -- We must also consider the case of call to a runtime function that + -- is not available in the configurable runtime. when N_Empty => pragma Assert (Serious_Errors_Detected /= 0 @@ -609,11 +615,9 @@ package body Sem is -- analyzed. when - N_SCIL_Dispatch_Table_Object_Init | - N_SCIL_Dispatch_Table_Tag_Init | - N_SCIL_Dispatching_Call | - N_SCIL_Membership_Test | - N_SCIL_Tag_Init => + N_SCIL_Dispatch_Table_Tag_Init | + N_SCIL_Dispatching_Call | + N_SCIL_Membership_Test => null; -- For the remaining node types, we generate compiler abort, because @@ -629,6 +633,7 @@ package body Sem is N_Access_Function_Definition | N_Access_Procedure_Definition | N_Access_To_Object_Definition | + N_Case_Expression_Alternative | N_Case_Statement_Alternative | N_Compilation_Unit_Aux | N_Component_Association | @@ -841,7 +846,7 @@ package body Sem is return; end if; - -- Now search the global entity suppress table for a matching entry + -- Now search the global entity suppress table for a matching entry. -- We also search this in reverse order so that if there are multiple -- pragmas for the same entity, the last one applies. @@ -1109,12 +1114,12 @@ package body Sem is Node := First (L); Insert_List_After (N, L); - -- Now just analyze from the original first node until we get to - -- the successor of the original insertion point (which may be - -- Empty if the insertion point was at the end of the list). Note - -- that this properly handles the case where any of the analyze - -- calls result in the insertion of nodes after the analyzed - -- node (possibly calling this routine recursively). + -- Now just analyze from the original first node until we get to the + -- successor of the original insertion point (which may be Empty if + -- the insertion point was at the end of the list). Note that this + -- properly handles the case where any of the analyze calls result in + -- the insertion of nodes after the analyzed node (possibly calling + -- this routine recursively). while Node /= After loop Analyze (Node); @@ -1160,9 +1165,9 @@ package body Sem is begin if Is_Non_Empty_List (L) then - -- Capture the Node_Id of the first list node to be inserted. - -- This will still be the first node after the insert operation, - -- since Insert_List_After does not modify the Node_Id values. + -- Capture the Node_Id of the first list node to be inserted. This + -- will still be the first node after the insert operation, since + -- Insert_List_After does not modify the Node_Id values. Node := First (L); Insert_List_Before (N, L); @@ -1217,9 +1222,9 @@ package body Sem is Ptr : Suppress_Stack_Entry_Ptr; begin - -- First search the local entity suppress stack, we search this from the - -- top of the stack down, so that we get the innermost entry that - -- applies to this case if there are nested entries. + -- First search the local entity suppress stack. We search this from the + -- top of the stack down so that we get the innermost entry that applies + -- to this case if there are nested entries. Ptr := Local_Suppress_Stack_Top; while Ptr /= null loop @@ -1232,7 +1237,7 @@ package body Sem is Ptr := Ptr.Prev; end loop; - -- Now search the global entity suppress table for a matching entry + -- Now search the global entity suppress table for a matching entry. -- We also search this from the top down so that if there are multiple -- pragmas for the same entity, the last one applies (not clear what -- or whether the RM specifies this handling, but it seems reasonable). @@ -1322,10 +1327,10 @@ package body Sem is procedure Semantics (Comp_Unit : Node_Id) is -- The following locations save the corresponding global flags and - -- variables so that they can be restored on completion. This is - -- needed so that calls to Rtsfind start with the proper default - -- values for these variables, and also that such calls do not - -- disturb the settings for units being analyzed at a higher level. + -- variables so that they can be restored on completion. This is needed + -- so that calls to Rtsfind start with the proper default values for + -- these variables, and also that such calls do not disturb the settings + -- for units being analyzed at a higher level. S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Full_Analysis : constant Boolean := Full_Analysis; @@ -1343,12 +1348,12 @@ package body Sem is -- context, is compiled with expansion disabled. Save_Config_Switches : Config_Switches_Type; - -- Variable used to save values of config switches while we analyze - -- the new unit, to be restored on exit for proper recursive behavior. + -- Variable used to save values of config switches while we analyze the + -- new unit, to be restored on exit for proper recursive behavior. procedure Do_Analyze; - -- Procedure to analyze the compilation unit. This is called more - -- than once when the high level optimizer is activated. + -- Procedure to analyze the compilation unit. This is called more than + -- once when the high level optimizer is activated. ---------------- -- Do_Analyze -- @@ -1579,12 +1584,12 @@ package body Sem is when N_Package_Body => - -- Package bodies are processed separately if the main - -- unit depends on them. + -- Package bodies are processed separately if the main unit + -- depends on them. null; - when N_Subprogram_Body => + when N_Subprogram_Body => -- A subprogram body must be the main unit @@ -1592,14 +1597,17 @@ package body Sem is or else CU = Cunit (Main_Unit)); null; - -- All other cases cannot happen - when N_Function_Instantiation | N_Procedure_Instantiation | N_Package_Instantiation => - pragma Assert (False, "instantiation"); + + -- Can only happen if some generic body (needed for gnat2scil + -- traversal, but not by GNAT) is not available, ignore. + null; + -- All other cases cannot happen + when N_Subunit => pragma Assert (False, "subunit"); null; @@ -1701,6 +1709,18 @@ package body Sem is procedure Do_Withed_Unit (Withed_Unit : Node_Id) is begin Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit)); + + -- If the unit in the with_clause is a generic instance, the clause + -- now denotes the instance body. Traverse the corresponding spec + -- because there may be no other dependence that will force the + -- traversal of its own context. + + if Nkind (Unit (Withed_Unit)) = N_Package_Body + and then Is_Generic_Instance + (Defining_Entity (Unit (Library_Unit (Withed_Unit)))) + then + Do_Withed_Unit (Library_Unit (Withed_Unit)); + end if; end Do_Withed_Unit; ---------------------------- @@ -1708,13 +1728,12 @@ package body Sem is ---------------------------- procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is - Unit_Num : constant Unit_Number_Type := - Get_Cunit_Unit_Number (CU); + Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU); + Child : Node_Id; + Parent_CU : Node_Id; procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); - -- Start of processing for Do_Unit_And_Dependents - begin if not Seen (Unit_Num) then @@ -1722,13 +1741,12 @@ package body Sem is Do_Withed_Units (CU, Include_Limited => False); - -- Process the unit if it is a spec or the the main unit, if - -- it has no previous spec or we have done all other units. + -- Process the unit if it is a spec or the the main unit, if it + -- has no previous spec or we have done all other units. if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) or else Acts_As_Spec (CU) then - if CU = Cunit (Main_Unit) and then not Do_Main then @@ -1739,6 +1757,20 @@ package body Sem is if CU = Library_Unit (Main_CU) then Process_Bodies_In_Context (CU); + + -- If main is a child unit, examine context of parent + -- units to see if they include instantiated units. + + if Is_Child_Unit (Cunit_Entity (Main_Unit)) then + Child := Cunit_Entity (Main_Unit); + while Is_Child_Unit (Child) loop + Parent_CU := + Cunit + (Get_Cunit_Entity_Unit_Number (Scope (Child))); + Process_Bodies_In_Context (Parent_CU); + Child := Scope (Child); + end loop; + end if; end if; Do_Action (CU, Item); @@ -1761,9 +1793,13 @@ package body Sem is procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); function Depends_On_Main (CU : Node_Id) return Boolean; - -- The body of a unit that is withed by the spec of the main - -- unit may in turn have a with_clause on that spec. In that - -- case do not traverse the body, to prevent loops. + -- The body of a unit that is withed by the spec of the main unit + -- may in turn have a with_clause on that spec. In that case do not + -- traverse the body, to prevent loops. It can also happen that the + -- main body as a with_clause on a child, which of course has an + -- implicit with on its parent. It's ok to traverse the child body + -- if the main spec has been processed, otherwise we also have a + -- circularity to avoid. --------------------- -- Depends_On_Main -- @@ -1784,6 +1820,8 @@ package body Sem is while Present (CL) loop if Nkind (CL) = N_With_Clause and then Library_Unit (CL) = Library_Unit (Main_CU) + and then + not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) then return True; end if; @@ -1832,7 +1870,7 @@ package body Sem is -- Local Declarations - Cur : Elmt_Id; + Cur : Elmt_Id; -- Start of processing for Walk_Library_Items @@ -1885,15 +1923,15 @@ package body Sem is -- separate spec. -- If it's a package body, ignore it, unless it is a body - -- created for an instance that is the main unit. In the - -- case of subprograms, the body is the wrapper package. In - -- case of a package, the original file carries the body, - -- and the spec appears as a later entry in the units list. + -- created for an instance that is the main unit. In the case + -- of subprograms, the body is the wrapper package. In case of + -- a package, the original file carries the body, and the spec + -- appears as a later entry in the units list. - -- Otherwise Bodies appear in the list only because of - -- inlining/instantiations, and they are processed only - -- if relevant to the main unit. The main unit itself - -- is processed separately after all other specs. + -- Otherwise Bodies appear in the list only because of inlining + -- or instantiations, and they are processed only if relevant + -- to the main unit. The main unit itself is processed + -- separately after all other specs. when N_Subprogram_Body => if Acts_As_Spec (N) then @@ -1911,7 +1949,7 @@ package body Sem is Unit (Library_Unit (Main_CU))); end if; - -- It's a spec, process it, and the units it depends on. + -- It's a spec, process it, and the units it depends on when others => Do_Unit_And_Dependents (CU, N); @@ -1921,8 +1959,8 @@ package body Sem is Next_Elmt (Cur); end loop; - -- Now process package bodies on which main depends, followed by - -- bodies of parents, if present, and finally main itself. + -- Now process package bodies on which main depends, followed by bodies + -- of parents, if present, and finally main itself. if not Done (Main_Unit) then Do_Main := True; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3b0bda0753a..5ff55cec1b2 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -54,6 +54,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stringt; use Stringt; with Stand; use Stand; +with Style; use Style; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -1443,8 +1444,9 @@ package body Sem_Aggr is -- a missing component association for a 1-aggregate. if Paren_Count (Expr) > 0 then - Error_Msg_N ("\if single-component aggregate is intended," - & " write e.g. (1 ='> ...)", Expr); + Error_Msg_N + ("\if single-component aggregate is intended," + & " write e.g. (1 ='> ...)", Expr); end if; return Failure; end if; @@ -1798,8 +1800,8 @@ package body Sem_Aggr is elsif Is_Tagged_Type (Etype (Expression (Assoc))) then Check_Dynamically_Tagged_Expression - (Expr => Expression (Assoc), - Typ => Component_Type (Etype (N)), + (Expr => Expression (Assoc), + Typ => Component_Type (Etype (N)), Related_Nod => N); end if; @@ -2288,6 +2290,18 @@ package body Sem_Aggr is then A_Type := Etype (Imm_Type); return True; + + -- The parent type may be a private extension. The aggregate is + -- legal if the type of the aggregate is an extension of it that + -- is not a private extension. + + elsif Is_Private_Type (A_Type) + and then not Is_Private_Type (Imm_Type) + and then Present (Full_View (A_Type)) + and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type) + then + return True; + else Imm_Type := Etype (Base_Type (Imm_Type)); end if; @@ -2488,21 +2502,24 @@ package body Sem_Aggr is -- whose value may already have been specified by N's ancestor part. -- This routine checks whether this is indeed the case and if so returns -- False, signaling that no value for Discr should appear in N's - -- aggregate part. Also, in this case, the routine appends - -- New_Assoc_List Discr the discriminant value specified in the ancestor - -- part. - -- Can't parse previous sentence, appends what where??? + -- aggregate part. Also, in this case, the routine appends to + -- New_Assoc_List the discriminant value specified in the ancestor part. + -- + -- If the aggregate is in a context with expansion delayed, it will be + -- reanalyzed. The inherited discriminant values must not be reinserted + -- in the component list to prevent spurious errors, but they must be + -- present on first analysis to build the proper subtype indications. + -- The flag Inherited_Discriminant is used to prevent the re-insertion. function Get_Value (Compon : Node_Id; From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id; - -- Given a record component stored in parameter Compon, the following - -- function returns its value as it appears in the list From, which is - -- a list of N_Component_Association nodes. - -- What is this referring to??? There is no "following function" in - -- sight??? + -- Given a record component stored in parameter Compon, this function + -- returns its value as it appears in the list From, which is a list + -- of N_Component_Association nodes. + -- -- If no component association has a choice for the searched component, -- the value provided by the others choice is returned, if there is one, -- and Consider_Others_Choice is set to true. Otherwise Empty is @@ -2556,6 +2573,7 @@ package body Sem_Aggr is Loc : Source_Ptr; Ancestor : Node_Id; + Comp_Assoc : Node_Id; Discr_Expr : Node_Id; Ancestor_Typ : Entity_Id; @@ -2570,6 +2588,21 @@ package body Sem_Aggr is return True; end if; + -- Check whether inherited discriminant values have already been + -- inserted in the aggregate. This will be the case if we are + -- re-analyzing an aggregate whose expansion was delayed. + + if Present (Component_Associations (N)) then + Comp_Assoc := First (Component_Associations (N)); + while Present (Comp_Assoc) loop + if Inherited_Discriminant (Comp_Assoc) then + return True; + end if; + + Next (Comp_Assoc); + end loop; + end if; + Ancestor := Ancestor_Part (N); Ancestor_Typ := Etype (Ancestor); Loc := Sloc (Ancestor); @@ -2627,6 +2660,7 @@ package body Sem_Aggr is end if; Resolve_Aggr_Expr (Discr_Expr, Discr); + Set_Inherited_Discriminant (Last (New_Assoc_List)); return False; end if; @@ -2991,13 +3025,15 @@ package body Sem_Aggr is if Selector_Name /= First (Choices (Assoc)) or else Present (Next (Selector_Name)) then - Error_Msg_N ("OTHERS must appear alone in a choice list", - Selector_Name); + Error_Msg_N + ("OTHERS must appear alone in a choice list", + Selector_Name); return; elsif Present (Next (Assoc)) then - Error_Msg_N ("OTHERS must appear last in an aggregate", - Selector_Name); + Error_Msg_N + ("OTHERS must appear last in an aggregate", + Selector_Name); return; -- (Ada2005): If this is an association with a box, @@ -3213,18 +3249,17 @@ package body Sem_Aggr is Error_Msg_NE ("type of aggregate has private ancestor&!", N, Root_Typ); - Error_Msg_N ("must use extension aggregate!", N); + Error_Msg_N ("must use extension aggregate!", N); return; end if; Dnode := Declaration_Node (Base_Type (Root_Typ)); - -- If we don't get a full declaration, then we have some - -- error which will get signalled later so skip this part. - -- Otherwise, gather components of root that apply to the - -- aggregate type. We use the base type in case there is an - -- applicable stored constraint that renames the discriminants - -- of the root. + -- If we don't get a full declaration, then we have some error + -- which will get signalled later so skip this part. Otherwise + -- gather components of root that apply to the aggregate type. + -- We use the base type in case there is an applicable stored + -- constraint that renames the discriminants of the root. if Nkind (Dnode) = N_Full_Type_Declaration then Record_Def := Type_Definition (Dnode); @@ -3259,6 +3294,15 @@ package body Sem_Aggr is Ancestor_Part (N), Parent_Typ); return; end if; + + -- The current view of ancestor part may be a private type, + -- while the context type is always non-private. + + elsif Is_Private_Type (Root_Typ) + and then Present (Full_View (Root_Typ)) + and then Nkind (N) = N_Extension_Aggregate + then + exit when Base_Type (Full_View (Root_Typ)) = Parent_Typ; end if; end loop; @@ -3460,8 +3504,8 @@ package body Sem_Aggr is -- subaggregate is needed. Capture_Discriminants : declare - Loc : constant Source_Ptr := Sloc (N); - Expr : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + Expr : Node_Id; procedure Add_Discriminant_Values (New_Aggr : Node_Id; @@ -3567,7 +3611,6 @@ package body Sem_Aggr is New_Aggr : Node_Id; begin - Inner_Comp := First_Component (Etype (Comp)); while Present (Inner_Comp) loop Comp_Type := Etype (Inner_Comp); @@ -3580,7 +3623,7 @@ package body Sem_Aggr is Set_Etype (New_Aggr, Comp_Type); Add_Association (Inner_Comp, New_Aggr, - Component_Associations (Aggr)); + Component_Associations (Aggr)); -- Collect discriminant values and recurse @@ -3630,7 +3673,7 @@ package body Sem_Aggr is else declare - Comp : Entity_Id; + Comp : Entity_Id; begin -- If the type has additional components, create @@ -3737,7 +3780,15 @@ package body Sem_Aggr is New_Assoc := First (New_Assoc_List); while Present (New_Assoc) loop Component := First (Choices (New_Assoc)); - exit when Chars (Selectr) = Chars (Component); + + if Chars (Selectr) = Chars (Component) then + if Style_Check then + Check_Identifier (Selectr, Entity (Component)); + end if; + + exit; + end if; + Next (New_Assoc); end loop; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e37b216ca45..8b5fd1313da 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -136,6 +136,7 @@ package body Sem_Attr is Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_Machine_Rounding | + Attribute_Mod | Attribute_Priority | Attribute_Stream_Size | Attribute_Wide_Wide_Width => True, @@ -2384,8 +2385,8 @@ package body Sem_Attr is and then Base_Type (Typ) = Typ and then Warn_On_Redundant_Constructs then - Error_Msg_NE - ("?redundant attribute, & is its own base type", N, Typ); + Error_Msg_NE -- CODEFIX + ("?redundant attribute, & is its own base type", N, Typ); end if; Set_Etype (N, Base_Type (Entity (P))); @@ -2775,10 +2776,8 @@ package body Sem_Attr is exit; elsif Ekind (Scope (Ent)) in Task_Kind - and then Ekind (S) /= E_Loop - and then Ekind (S) /= E_Block - and then Ekind (S) /= E_Entry - and then Ekind (S) /= E_Entry_Family + and then + not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family) then Error_Attr ("Attribute % cannot appear in inner unit", N); @@ -3546,13 +3545,9 @@ package body Sem_Attr is ---------------------- procedure Must_Be_Imported (Proc_Ent : Entity_Id) is - Pent : Entity_Id := Proc_Ent; + Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent); begin - while Present (Alias (Pent)) loop - Pent := Alias (Pent); - end loop; - -- Ignore check if procedure not frozen yet (we will get -- another chance when the default parameter is reanalyzed) @@ -3654,6 +3649,7 @@ package body Sem_Attr is function Process (N : Node_Id) return Traverse_Result is begin if Is_Entity_Name (N) + and then Present (Entity (N)) and then not Is_Formal (Entity (N)) and then Enclosing_Subprogram (Entity (N)) = Subp then @@ -4809,9 +4805,11 @@ package body Sem_Attr is -- processing, since otherwise gigi might see an attribute which it is -- unprepared to deal with. - function Aft_Value return Nat; - -- Computes Aft value for current attribute prefix (used by Aft itself - -- and also by Width for computing the Width of a fixed point type). + procedure Check_Concurrent_Discriminant (Bound : Node_Id); + -- If Bound is a reference to a discriminant of a task or protected type + -- occurring within the object's body, rewrite attribute reference into + -- a reference to the corresponding discriminal. Use for the expansion + -- of checks against bounds of entry family index subtypes. procedure Check_Expressions; -- In case where the attribute is not foldable, the expressions, if @@ -4878,24 +4876,33 @@ package body Sem_Attr is -- Verify that the prefix of a potentially static array attribute -- satisfies the conditions of 4.9 (14). - --------------- - -- Aft_Value -- - --------------- + ----------------------------------- + -- Check_Concurrent_Discriminant -- + ----------------------------------- - function Aft_Value return Nat is - Result : Nat; - Delta_Val : Ureal; + procedure Check_Concurrent_Discriminant (Bound : Node_Id) is + Tsk : Entity_Id; + -- The concurrent (task or protected) type begin - Result := 1; - Delta_Val := Delta_Value (P_Type); - while Delta_Val < Ureal_Tenth loop - Delta_Val := Delta_Val * Ureal_10; - Result := Result + 1; - end loop; + if Nkind (Bound) = N_Identifier + and then Ekind (Entity (Bound)) = E_Discriminant + and then Is_Concurrent_Record_Type (Scope (Entity (Bound))) + then + Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound))); - return Result; - end Aft_Value; + if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then + + -- Find discriminant of original concurrent type, and use + -- its current discriminal, which is the renaming within + -- the task/protected body. + + Rewrite (N, + New_Occurrence_Of + (Find_Body_Discriminal (Entity (Bound)), Loc)); + end if; + end if; + end Check_Concurrent_Discriminant; ----------------------- -- Check_Expressions -- @@ -5626,10 +5633,10 @@ package body Sem_Attr is while Present (N) loop Static := Static and then Is_Static_Subtype (Etype (N)); - -- If however the index type is generic, attributes cannot - -- be folded. + -- If however the index type is generic, or derived from + -- one, attributes cannot be folded. - if Is_Generic_Type (Etype (N)) + if Is_Generic_Type (Root_Type (Etype (N))) and then Id /= Attribute_Component_Size then return; @@ -5756,7 +5763,7 @@ package body Sem_Attr is --------- when Attribute_Aft => - Fold_Uint (N, UI_From_Int (Aft_Value), True); + Fold_Uint (N, Aft_Value (P_Type), True); --------------- -- Alignment -- @@ -5984,6 +5991,9 @@ package body Sem_Attr is else Fold_Uint (N, Expr_Value (Lo_Bound), Static); end if; + + else + Check_Concurrent_Discriminant (Lo_Bound); end if; end First_Attr; @@ -6172,6 +6182,9 @@ package body Sem_Attr is else Fold_Uint (N, Expr_Value (Hi_Bound), Static); end if; + + else + Check_Concurrent_Discriminant (Hi_Bound); end if; end Last; @@ -6192,13 +6205,13 @@ package body Sem_Attr is Ind : Node_Id; begin - -- In the case of a generic index type, the bounds may appear static - -- but the computation is not meaningful in this case, and may - -- generate a spurious warning. + -- If any index type is a formal type, or derived from one, the + -- bounds are not static. Treating them as static can produce + -- spurious warnings or improper constant folding. Ind := First_Index (P_Type); while Present (Ind) loop - if Is_Generic_Type (Etype (Ind)) then + if Is_Generic_Type (Root_Type (Etype (Ind))) then return; end if; @@ -7328,7 +7341,8 @@ package body Sem_Attr is -- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34)) Fold_Uint - (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True); + (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), + True); end if; -- Discrete types @@ -7645,8 +7659,7 @@ package body Sem_Attr is -- know will fail, so generate an appropriate warning. if In_Instance_Body then - Error_Msg_F - ("?non-local pointer cannot point to local object", P); + Error_Msg_F ("?non-local pointer cannot point to local object", P); Error_Msg_F ("\?Program_Error will be raised at run time", P); Rewrite (N, @@ -7656,8 +7669,7 @@ package body Sem_Attr is return; else - Error_Msg_F - ("non-local pointer cannot point to local object", P); + Error_Msg_F ("non-local pointer cannot point to local object", P); -- Check for case where we have a missing access definition @@ -7813,11 +7825,9 @@ package body Sem_Attr is -- also be accessibility checks on those, this is where the -- checks can eventually be centralized ??? - if Ekind (Btyp) = E_Access_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type + if Ekind_In (Btyp, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) then -- Deal with convention mismatch @@ -8244,9 +8254,8 @@ package body Sem_Attr is end if; end if; - if Ekind (Btyp) = E_Access_Protected_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type + if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type) then if Is_Entity_Name (P) and then not Is_Protected_Type (Scope (Entity (P))) @@ -8268,9 +8277,8 @@ package body Sem_Attr is return; end if; - elsif (Ekind (Btyp) = E_Access_Subprogram_Type - or else - Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type) + elsif Ekind_In (Btyp, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type then Error_Msg_F ("context requires a non-protected subprogram", P); diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index c1b3a331892..99bec9b72da 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -312,8 +312,8 @@ package body Sem_Aux is Ent : Entity_Id; begin - -- If the base type has no freeze node, it is a type in Standard, - -- and always acts as its own first subtype unless it is one of the + -- If the base type has no freeze node, it is a type in Standard, and + -- always acts as its own first subtype, except where it is one of the -- predefined integer types. If the type is formal, it is also a first -- subtype, and its base type has no freeze node. On the other hand, a -- subtype of a generic formal is not its own first subtype. Its base @@ -321,7 +321,6 @@ package body Sem_Aux is -- the first subtype is obtained. if No (F) then - if B = Base_Type (Standard_Integer) then return Standard_Integer; @@ -800,4 +799,20 @@ package body Sem_Aux is Obsolescent_Warnings.Tree_Write; end Tree_Write; + -------------------- + -- Ultimate_Alias -- + -------------------- + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + pragma Assert (Alias (E) /= E); + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + end Sem_Aux; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 464a764a3e3..8b763e05240 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -193,4 +193,9 @@ package Sem_Aux is function Number_Discriminants (Typ : Entity_Id) return Pos; -- Typ is a type with discriminants, yields number of discriminants in type + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; + pragma Inline (Ultimate_Alias); + -- Return the last entity in the chain of aliased entities of Prim. If Prim + -- has no alias return Prim. + end Sem_Aux; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index da260f35c4a..fc8806a036f 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index dcc72931551..78ae7c61b3b 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, 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- -- @@ -68,7 +68,7 @@ package Sem_Case is -- Processing to carry out for a non static Choice with procedure Process_Associated_Node (A : Node_Id); - -- Associated to each case alternative, aggregate component + -- Associated with each case alternative, aggregate component -- association or record variant A there is a node or list of nodes -- that need semantic processing. This routine implements that -- processing. @@ -76,9 +76,9 @@ package Sem_Case is package Generic_Choices_Processing is function Number_Of_Choices (N : Node_Id) return Nat; - -- Iterates through the choices of N, (N can be a case statement, - -- array aggregate or record variant), counting all the Choice nodes - -- except for the Others choice. + -- Iterates through the choices of N, (N can be a case expression, case + -- statement, array aggregate or record variant), counting all the + -- Choice nodes except for the Others choice. procedure Analyze_Choices (N : Node_Id; @@ -87,10 +87,10 @@ package Sem_Case is Last_Choice : out Nat; Raises_CE : out Boolean; Others_Present : out Boolean); - -- From a case statement, array aggregate or record variant N, this - -- routine analyzes the corresponding list of discrete choices. - -- Subtyp is the subtype of the discrete choices. The type against - -- which the discrete choices must be resolved is its base type. + -- From a case expression, case statement, array aggregate or record + -- variant N, this routine analyzes the corresponding list of discrete + -- choices. Subtyp is the subtype of the discrete choices. The type + -- against which the discrete choices must be resolved is its base type. -- -- On entry Choice_Table must be big enough to contain all the discrete -- choices encountered. The lower bound of Choice_Table must be one. diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index c8d06e8cfec..1f4ed1069f6 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -78,12 +78,12 @@ package body Sem_Cat is function In_RCI_Declaration (N : Node_Id) return Boolean; -- Determines if a declaration is within the visible part of a Remote - -- Call Interface compilation unit, for semantic checking purposes only, + -- Call Interface compilation unit, for semantic checking purposes only -- (returns false within an instance and within the package body). function In_RT_Declaration return Boolean; - -- Determines if current scope is within a Remote Types compilation unit, - -- for semantic checking purposes. + -- Determines if current scope is within the declaration of a Remote Types + -- unit, for semantic checking purposes. function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean; -- Returns true if the entity is a type whose full view is a non-remote @@ -1061,28 +1061,25 @@ package body Sem_Cat is -- Exclude generic specs from the checks (this will get rechecked -- on instantiations). - if Inside_A_Generic - and then No (Enclosing_Generic_Body (Id)) - then + if Inside_A_Generic and then No (Enclosing_Generic_Body (Id)) then return; end if; - -- Required checks for declaration that is in a preelaborated - -- package and is not within some subprogram. + -- Required checks for declaration that is in a preelaborated package + -- and is not within some subprogram. if In_Preelaborated_Unit and then not In_Subprogram_Or_Concurrent_Unit then -- Check for default initialized variable case. Note that in - -- accordance with (RM B.1(24)) imported objects are not - -- subject to default initialization. + -- accordance with (RM B.1(24)) imported objects are not subject to + -- default initialization. -- If the initialization does not come from source and is an -- aggregate, it is a static initialization that replaces an -- implicit call, and must be treated as such. if Present (E) - and then - (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate) + and then (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate) then null; @@ -1210,13 +1207,8 @@ package body Sem_Cat is elsif Nkind (Odf) = N_Subtype_Indication then Ent := Etype (Subtype_Mark (Odf)); - elsif - Nkind (Odf) = N_Constrained_Array_Definition - then + elsif Nkind (Odf) = N_Constrained_Array_Definition then Ent := Component_Type (T); - - -- else - -- return; end if; if Is_Task_Type (Ent) @@ -1230,9 +1222,9 @@ package body Sem_Cat is end; end if; - -- Non-static discriminant not allowed in preelaborated unit - -- Controlled object of a type with a user-defined Initialize - -- is forbidden as well. + -- Non-static discriminants not allowed in preelaborated unit. + -- Objects of a controlled type with a user-defined Initialize + -- are forbidden as well. if Is_Record_Type (Etype (Id)) then declare @@ -1248,7 +1240,7 @@ package body Sem_Cat is if Nkind (PEE) = N_Full_Type_Declaration and then not Static_Discriminant_Expr - (Discriminant_Specifications (PEE)) + (Discriminant_Specifications (PEE)) then Error_Msg_N ("non-static discriminant in preelaborated unit", @@ -1270,23 +1262,21 @@ package body Sem_Cat is -- except within a subprogram, generic subprogram, task unit, or -- protected unit (RM 10.2.1(16)). - if In_Pure_Unit - and then not In_Subprogram_Task_Protected_Unit - then + if In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit then Error_Msg_N ("declaration of variable not allowed in pure unit", N); -- The visible part of an RCI library unit must not contain the -- declaration of a variable (RM E.1.3(9)) elsif In_RCI_Declaration (N) then - Error_Msg_N ("declaration of variable not allowed in rci unit", N); + Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N); -- The visible part of a Shared Passive library unit must not contain -- the declaration of a variable (RM E.2.2(7)) - elsif In_RT_Declaration then + elsif In_RT_Declaration and then not In_Private_Part (Id) then Error_Msg_N - ("variable declaration not allowed in remote types unit", N); + ("visible variable not allowed in remote types unit", N); end if; end Validate_Object_Declaration; @@ -1397,8 +1387,8 @@ package body Sem_Cat is null; - elsif Ekind (Param_Type) = E_Anonymous_Access_Type - or else Ekind (Param_Type) = E_Anonymous_Access_Subprogram_Type + elsif Ekind_In (Param_Type, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then -- From RM E.2.2(14), no anonymous access parameter other than -- controlling ones may be used (because an anonymous access @@ -1454,9 +1444,9 @@ package body Sem_Cat is ("limited type not allowed in rci unit", Parent (E)); Explain_Limited_Type (E, Parent (E)); - elsif Ekind (E) = E_Generic_Function - or else Ekind (E) = E_Generic_Package - or else Ekind (E) = E_Generic_Procedure + elsif Ekind_In (E, E_Generic_Function, + E_Generic_Package, + E_Generic_Procedure) then Error_Msg_N ("generic declaration not allowed in rci unit", Parent (E)); @@ -1551,7 +1541,6 @@ package body Sem_Cat is Type_Decl := Parent (Param_Type); if Ekind (Param_Type) = E_Anonymous_Access_Type then - if K = N_Subprogram_Declaration then Error_Node := Param_Spec; end if; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 8a53d5891b6..1ce76e89c25 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -552,7 +552,8 @@ package body Sem_Ch10 is or else Used_In_Spec) then - Error_Msg_N ("?redundant with clause in body", Clause); + Error_Msg_N -- CODEFIX + ("?redundant with clause in body", Clause); end if; Used_In_Body := False; @@ -580,7 +581,8 @@ package body Sem_Ch10 is Exit_On_Self => True); if Withed then - Error_Msg_N ("?redundant with clause", Clause); + Error_Msg_N -- CODEFIX + ("?redundant with clause", Clause); end if; end; end if; @@ -690,8 +692,7 @@ package body Sem_Ch10 is end if; if Circularity then - Error_Msg_N - ("circular dependency caused by with_clauses", N); + Error_Msg_N ("circular dependency caused by with_clauses", N); Error_Msg_N ("\possibly missing limited_with clause" & " in one of the following", N); @@ -2139,6 +2140,19 @@ package body Sem_Ch10 is -- Start of processing for Analyze_Subunit begin + if Style_Check then + declare + Nam : Node_Id := Name (Unit (N)); + + begin + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + Check_Identifier (Nam, Par_Unit); + end; + end if; + if not Is_Empty_List (Context_Items (N)) then -- Save current use clauses @@ -2207,7 +2221,6 @@ package body Sem_Ch10 is if Present (Enclosing_Child) then Install_Siblings (Enclosing_Child, N); end if; - end if; Analyze (Proper_Body (Unit (N))); @@ -3373,6 +3386,11 @@ package body Sem_Ch10 is -- units. The shadow entities are created when the inserted clause is -- analyzed. Implements Ada 2005 (AI-50217). + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean; + -- When compiling a unit Q descended from some parent unit P, a limited + -- with_clause in the context of P that names some other ancestor of Q + -- must not be installed because the ancestor is immediately visible. + --------------------- -- Check_Renamings -- --------------------- @@ -3645,6 +3663,22 @@ package body Sem_Ch10 is New_Nodes_OK := New_Nodes_OK - 1; end Expand_Limited_With_Clause; + ---------------------- + -- Is_Ancestor_Unit -- + ---------------------- + + function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean is + E1 : constant Entity_Id := Defining_Entity (Unit (U1)); + E2 : Entity_Id; + begin + if Nkind_In (Unit (U2), N_Package_Body, N_Subprogram_Body) then + E2 := Defining_Entity (Unit (Library_Unit (U2))); + return Is_Ancestor_Package (E1, E2); + else + return False; + end if; + end Is_Ancestor_Unit; + -- Start of processing for Install_Limited_Context_Clauses begin @@ -3678,6 +3712,9 @@ package body Sem_Ch10 is if Library_Unit (Item) /= Cunit (Current_Sem_Unit) and then not Limited_View_Installed (Item) + and then + not Is_Ancestor_Unit + (Library_Unit (Item), Cunit (Current_Sem_Unit)) then if not Private_Present (Item) or else Private_Present (N) @@ -4013,7 +4050,8 @@ package body Sem_Ch10 is function In_Context return Boolean; -- 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. + -- on a parent, in which case child unit is visible. If the + -- unit is a grand-child, the same applies to its parent. ---------------- -- In_Context -- @@ -4027,10 +4065,15 @@ package body Sem_Ch10 is if Nkind (Clause) = N_With_Clause and then Comes_From_Source (Clause) and then Is_Entity_Name (Name (Clause)) - and then Entity (Name (Clause)) = Id and then not Private_Present (Clause) then - return True; + if Entity (Name (Clause)) = Id + or else + (Nkind (Name (Clause)) = N_Expanded_Name + and then Entity (Prefix (Name (Clause))) = Id) + then + return True; + end if; end if; Next (Clause); @@ -5346,7 +5389,7 @@ package body Sem_Ch10 is -- and the full-view. if No (Class_Wide_Type (T)) then - CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + CW := Make_Temporary (Loc, 'S'); -- Set parent to be the same as the parent of the tagged type. -- We need a parent field set, and it is supposed to point to @@ -5398,9 +5441,7 @@ package body Sem_Ch10 is Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is - E : constant Entity_Id := - Make_Defining_Identifier (Sloc_Value, - Chars => New_Internal_Name (Id_Char)); + E : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin Set_Ekind (E, Kind); @@ -5475,9 +5516,7 @@ package body Sem_Ch10 is -- Build the header of the limited_view - Lim_Header := - Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name (Id_Char => 'Z')); + Lim_Header := Make_Temporary (Sloc (N), 'Z'); Set_Ekind (Lim_Header, E_Package); Set_Is_Internal (Lim_Header); Set_Limited_View (P, Lim_Header); @@ -5535,9 +5574,7 @@ package body Sem_Ch10 is then return True; - elsif Ekind (E) = E_Generic_Function - or else Ekind (E) = E_Generic_Procedure - then + elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then return True; elsif Ekind (E) = E_Generic_Package @@ -5578,10 +5615,7 @@ package body Sem_Ch10 is then Set_Body_Needed_For_SAL (Unit_Name); - elsif Ekind (Unit_Name) = E_Generic_Procedure - or else - Ekind (Unit_Name) = E_Generic_Function - then + elsif Ekind_In (Unit_Name, E_Generic_Procedure, E_Generic_Function) then Set_Body_Needed_For_SAL (Unit_Name); elsif Is_Subprogram (Unit_Name) @@ -5927,9 +5961,9 @@ package body Sem_Ch10 is if Nkind (Item) = N_With_Clause and then Private_Present (Item) then - -- If private_with_clause is redundant, remove it from - -- context, as a small optimization to subsequent handling - -- of private_with clauses in other nested packages.. + -- If private_with_clause is redundant, remove it from context, + -- as a small optimization to subsequent handling of private_with + -- clauses in other nested packages. if In_Regular_With_Clause (Entity (Name (Item))) then declare diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index d54c6f8a04f..cd6c10ba573 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index faff561e22b..a2009c2b66e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -2414,8 +2414,8 @@ package body Sem_Ch12 is end if; elsif Nkind (Prefix (Def)) = N_Selected_Component then - if Ekind (Entity (Selector_Name (Prefix (Def)))) - /= E_Entry_Family + if Ekind (Entity (Selector_Name (Prefix (Def)))) /= + E_Entry_Family then Error_Msg_N ("expect valid subprogram name as default", Def); end if; @@ -2598,7 +2598,7 @@ package body Sem_Ch12 is then Error_Msg_N ("premature usage of incomplete type", Def); - elsif Is_Internal (Designated_Type (T)) then + elsif not Is_Entity_Name (Subtype_Indication (Def)) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; @@ -3237,7 +3237,8 @@ package body Sem_Ch12 is or else Enclosing_Body_Present or else Present (Corresponding_Body (Gen_Decl))) and then (Is_In_Main_Unit (N) - or else Might_Inline_Subp) + or else Might_Inline_Subp + or else CodePeer_Mode) and then not Is_Actual_Pack and then not Inline_Now and then (Operating_Mode = Generate_Code @@ -3393,7 +3394,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)); end if; end if; @@ -3700,7 +3702,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)), Inlined_Body => True); Pop_Scope; @@ -3815,7 +3818,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)), Inlined_Body => True); end if; end Inline_Instance_Body; @@ -3854,7 +3858,8 @@ package body Sem_Ch12 is Expander_Status => Expander_Active, Current_Sem_Unit => Current_Sem_Unit, Scope_Suppress => Scope_Suppress, - Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, + Version => Ada_Version)); return True; else return False; @@ -4005,11 +4010,14 @@ package body Sem_Ch12 is -- If the instance is a child unit, mark the Id accordingly. Mark -- the anonymous entity as well, which is the real subprogram and -- which is used when the instance appears in a context clause. + -- Similarly, propagate the Is_Eliminated flag to handle properly + -- nested eliminated subprograms. Set_Is_Child_Unit (Act_Decl_Id, Is_Child_Unit (Defining_Entity (N))); Set_Is_Child_Unit (Anon_Id, Is_Child_Unit (Defining_Entity (N))); New_Overloaded_Entity (Act_Decl_Id); Check_Eliminated (Act_Decl_Id); + Set_Is_Eliminated (Anon_Id, Is_Eliminated (Act_Decl_Id)); -- In compilation unit case, kill elaboration checks on the -- instantiation, since they are never needed -- the body is @@ -4078,9 +4086,7 @@ package body Sem_Ch12 is -- Verify that it is a generic subprogram of the right kind, and that -- it does not lead to a circular instantiation. - if Ekind (Gen_Unit) /= E_Generic_Procedure - and then Ekind (Gen_Unit) /= E_Generic_Function - then + if not Ekind_In (Gen_Unit, E_Generic_Procedure, E_Generic_Function) then Error_Msg_N ("expect generic subprogram in instantiation", Gen_Id); elsif In_Open_Scopes (Gen_Unit) then @@ -4229,7 +4235,8 @@ package body Sem_Ch12 is then Error_Msg_NE ("access parameter& is controlling,", N, Formal); - Error_Msg_NE ("\corresponding parameter of & must be" + Error_Msg_NE + ("\corresponding parameter of & must be" & " explicitly null-excluding", N, Gen_Id); end if; @@ -7867,8 +7874,7 @@ package body Sem_Ch12 is if not Box_Present (Formal) then declare I_Pack : constant Entity_Id := - Make_Defining_Identifier (Sloc (Actual), - Chars => New_Internal_Name ('P')); + Make_Temporary (Sloc (Actual), 'P'); begin Set_Is_Internal (I_Pack); @@ -8167,9 +8173,8 @@ package body Sem_Ch12 is -- to prevent freezing anomalies. declare - Anon_Id : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('E')); + Anon_Id : constant Entity_Id := Make_Temporary (Loc, 'E'); + begin Set_Defining_Unit_Name (New_Spec, Anon_Id); Insert_Before (Instantiation_Node, Decl_Node); @@ -8316,8 +8321,7 @@ package body Sem_Ch12 is Subt_Decl := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, New_Internal_Name ('P')), + Defining_Identifier => Make_Temporary (Loc, 'P'), Subtype_Indication => New_Occurrence_Of (Ftyp, Loc)); Prepend (Subt_Decl, List); @@ -8590,6 +8594,7 @@ package body Sem_Ch12 is Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; if No (Gen_Body_Id) then Load_Parent_Of_Generic @@ -8748,11 +8753,16 @@ package body Sem_Ch12 is -- If we have no body, and the unit requires a body, then complain. This -- complaint is suppressed if we have detected other errors (since a -- common reason for missing the body is that it had errors). + -- In CodePeer mode, a warning has been emitted already, no need for + -- further messages. elsif Unit_Requires_Body (Gen_Unit) and then not Body_Optional then - if Serious_Errors_Detected = 0 then + if CodePeer_Mode then + null; + + elsif Serious_Errors_Detected = 0 then Error_Msg_NE ("cannot find body of generic package &", Inst_Node, Gen_Unit); @@ -8848,6 +8858,7 @@ package body Sem_Ch12 is Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; Scope_Suppress := Body_Info.Scope_Suppress; + Opt.Ada_Version := Body_Info.Version; if No (Gen_Body_Id) then @@ -9230,8 +9241,10 @@ package body Sem_Ch12 is elsif Ekind (A_Gen_T) = E_General_Access_Type and then Ekind (Base_Type (Act_T)) /= E_General_Access_Type then - Error_Msg_N ("actual must be general access type!", Actual); - Error_Msg_NE ("add ALL to }!", Actual, Act_T); + Error_Msg_N -- CODEFIX + ("actual must be general access type!", Actual); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", Actual, Act_T); Abandon_Instantiation (Actual); end if; end if; @@ -9860,9 +9873,7 @@ package body Sem_Ch12 is -- then so far the subprograms correspond, so -- now check that any result types correspond. - if No (Anc_Formal) - and then No (Act_Formal) - then + if No (Anc_Formal) and then No (Act_Formal) then Subprograms_Correspond := True; if Ekind (Act_Subp) = E_Function then @@ -10344,8 +10355,7 @@ package body Sem_Ch12 is Corr_Decl : Node_Id; begin - New_Corr := Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + New_Corr := Make_Temporary (Loc, 'S'); Corr_Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => New_Corr, @@ -10396,42 +10406,124 @@ package body Sem_Ch12 is ------------------ procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id) is - Inst_CU : constant Unit_Number_Type := Get_Source_Unit (Inst_Decl); + Loc : constant Source_Ptr := Sloc (Inst_Decl); + Inst_CU : constant Unit_Number_Type := Get_Code_Unit (Inst_Decl); + + -- Note that we use Get_Code_Unit to determine the position of the + -- instantiation, because it may itself appear within another instance + -- and we need to mark the context of the enclosing unit, not that of + -- the unit that contains the generic. + Gen_CU : constant Unit_Number_Type := Get_Source_Unit (Gen_Decl); + Inst : Entity_Id; Clause : Node_Id; + Scop : Entity_Id; + + procedure Add_Implicit_With (CU : Unit_Number_Type); + -- If a generic is instantiated in the direct or indirect context of + -- the current unit, but there is no with_clause for it in the current + -- context, add a with_clause for it to indicate that the body of the + -- generic should be examined before the current unit. + + procedure Add_Implicit_With (CU : Unit_Number_Type) is + Withn : constant Node_Id := + Make_With_Clause (Loc, + Name => New_Occurrence_Of (Cunit_Entity (CU), Loc)); + begin + Set_Implicit_With (Withn); + Set_Library_Unit (Withn, Cunit (CU)); + Set_Withed_Body (Withn, Cunit (CU)); + Prepend (Withn, Context_Items (Cunit (Inst_CU))); + end Add_Implicit_With; begin + -- This is only relevant when compiling for CodePeer. In what follows, + -- C is the current unit containing the instance body, and G is the + -- generic unit in that instance. + + if not CodePeer_Mode then + return; + end if; + + -- Nothing to do if G is local. + + if Inst_CU = Gen_CU then + return; + end if; + + -- If G is itself declared within an instance, indicate that the + -- generic body of that instance is also needed by C. This must be + -- done recursively. + + Scop := Scope (Defining_Entity (Gen_Decl)); + + while Is_Generic_Instance (Scop) + and then Ekind (Scop) = E_Package + loop + Mark_Context + (Inst_Decl, + Unit_Declaration_Node + (Generic_Parent + (Specification (Unit_Declaration_Node (Scop))))); + Scop := Scope (Scop); + end loop; + + -- Add references to other generic units in the context of G, because + -- they may be instantiated within G, and their bodies needed by C. + + Clause := First (Context_Items (Cunit (Gen_CU))); + + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause + and then + Nkind (Unit (Library_Unit (Clause))) + = N_Generic_Package_Declaration + then + Add_Implicit_With (Get_Source_Unit (Library_Unit (Clause))); + end if; + + Next (Clause); + end loop; + + -- Now indicate that the body of G is needed by C + Clause := First (Context_Items (Cunit (Inst_CU))); while Present (Clause) loop if Nkind (Clause) = N_With_Clause and then Library_Unit (Clause) = Cunit (Gen_CU) then Set_Withed_Body (Clause, Cunit (Gen_CU)); + return; end if; Next (Clause); end loop; - -- If the instance appears within another instantiated unit, check - -- whether it appears in the main unit, and indicate the need for - -- the body of the enclosing instance as well. + -- If the with-clause for G is not in the context of C, it may appear in + -- some ancestor of C. - if In_Extended_Main_Code_Unit (Inst_Decl) - and then Instantiation_Location (Sloc (Inst_Decl)) /= No_Location - and then Present (Library_Unit (Cunit (Main_Unit))) - and then Cunit (Inst_CU) /= Library_Unit (Cunit (Main_Unit)) - then - Clause := First (Context_Items (Library_Unit (Cunit (Main_Unit)))); + Inst := Cunit_Entity (Inst_CU); + while Is_Child_Unit (Inst) loop + Inst := Scope (Inst); + + Clause := + First (Context_Items (Parent (Unit_Declaration_Node (Inst)))); while Present (Clause) loop if Nkind (Clause) = N_With_Clause - and then Library_Unit (Clause) = Cunit (Gen_CU) + and then Library_Unit (Clause) = Cunit (Gen_CU) then Set_Withed_Body (Clause, Cunit (Gen_CU)); + return; end if; Next (Clause); end loop; - end if; + end loop; + + -- If not found, G comes from an instance elsewhere in the context. Make + -- the dependence explicit in the context of C. + + Add_Implicit_With (Gen_CU); end Mark_Context; --------------------- @@ -10494,8 +10586,8 @@ package body Sem_Ch12 is -- instantiations are available, we must analyze them, to ensure that -- the public symbols generated are the same when the unit is compiled -- to generate code, and when it is compiled in the context of a unit - -- that needs a particular nested instance. This process is applied - -- to both package and subprogram instances. + -- that needs a particular nested instance. This process is applied to + -- both package and subprogram instances. -------------------------------- -- Collect_Previous_Instances -- @@ -10645,9 +10737,8 @@ package body Sem_Ch12 is -- enclosing body. Because the generic body we need may use -- global entities declared in the enclosing package (including -- aggregates) it is in general necessary to compile this body - -- with expansion enabled. The exception is if we are within a - -- generic package, in which case the usual generic rule - -- applies. + -- with expansion enabled, except if we are within a generic + -- package, in which case the usual generic rule applies. declare Exp_Status : Boolean := True; @@ -10716,7 +10807,8 @@ package body Sem_Ch12 is Get_Code_Unit (Sloc (Node (Decl))), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => - Local_Suppress_Stack_Top); + Local_Suppress_Stack_Top, + Version => Ada_Version); -- Package instance @@ -10756,7 +10848,8 @@ package body Sem_Ch12 is Get_Code_Unit (Sloc (Inst_Node)), Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top => - Local_Suppress_Stack_Top)), + Local_Suppress_Stack_Top, + Version => Ada_Version)), Body_Optional => Body_Optional); end; end if; @@ -10779,11 +10872,20 @@ package body Sem_Ch12 is Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); begin - Error_Msg_Unit_1 := Bname; - Error_Msg_N ("this instantiation requires$!", N); - Error_Msg_File_1 := Get_File_Name (Bname, Subunit => False); - Error_Msg_N ("\but file{ was not found!", N); - raise Unrecoverable_Error; + -- In CodePeer mode, the missing body may make the analysis + -- incomplete, but we do not treat it as fatal. + + if CodePeer_Mode then + return; + + else + Error_Msg_Unit_1 := Bname; + Error_Msg_N ("this instantiation requires$!", N); + Error_Msg_File_1 := + Get_File_Name (Bname, Subunit => False); + Error_Msg_N ("\but file{ was not found!", N); + raise Unrecoverable_Error; + end if; end; end if; end if; @@ -11293,9 +11395,9 @@ package body Sem_Ch12 is -- exchanged explicitly now, in order to remain consistent with the -- view of the parent type. - if Ekind (Typ) = E_Private_Type - or else Ekind (Typ) = E_Limited_Private_Type - or else Ekind (Typ) = E_Record_Type_With_Private + if Ekind_In (Typ, E_Private_Type, + E_Limited_Private_Type, + E_Record_Type_With_Private) then Dep_Elmt := First_Elmt (Private_Dependents (Typ)); while Present (Dep_Elmt) loop @@ -12223,6 +12325,26 @@ package body Sem_Ch12 is -- All other cases than aggregates else + -- For pragmas, we propagate the Enabled status for the + -- relevant pragmas to the original generic tree. This was + -- originally needed for SCO generation. It is no longer + -- needed there (since we use the Sloc value in calls to + -- Set_SCO_Pragma_Enabled), but it seems a generally good + -- idea to have this flag set properly. + + if Nkind (N) = N_Pragma + and then + (Pragma_Name (N) = Name_Assert or else + Pragma_Name (N) = Name_Check or else + Pragma_Name (N) = Name_Precondition or else + Pragma_Name (N) = Name_Postcondition) + and then Present (Associated_Node (Pragma_Identifier (N))) + then + Set_Pragma_Enabled (N, + Pragma_Enabled + (Parent (Associated_Node (Pragma_Identifier (N))))); + end if; + Save_Global_Descendant (Field1 (N)); Save_Global_Descendant (Field2 (N)); Save_Global_Descendant (Field3 (N)); @@ -12304,19 +12426,22 @@ package body Sem_Ch12 is Act_Unit : Entity_Id) is begin - -- Regardless of the current mode, predefined units are analyzed in - -- the most current Ada mode, and earlier version Ada checks do not - -- apply to predefined units. Nothing needs to be done for non-internal - -- units. These are always analyzed in the current mode. + -- Regardless of the current mode, predefined units are analyzed in the + -- most current Ada mode, and earlier version Ada checks do not apply + -- to predefined units. Nothing needs to be done for non-internal units. + -- These are always analyzed in the current mode. if Is_Internal_File_Name - (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), - Renamings_Included => True) + (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), + Renamings_Included => True) then Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); end if; - Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null); + Current_Instantiated_Parent := + (Gen_Id => Gen_Unit, + Act_Id => Act_Unit, + Next_In_HTable => Assoc_Null); end Set_Instance_Env; ----------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a14f4146a45..8b1d60aa153 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -73,10 +73,6 @@ package body Sem_Ch13 is -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); - -- Given two entities for record components or discriminants, checks - -- if they have overlapping component clauses and issues errors if so. - function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding -- Uint value. If the value is inappropriate, then error messages are @@ -180,265 +176,421 @@ package body Sem_Ch13 is ----------------------------------------- procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is - Max_Machine_Scalar_Size : constant Uint := - UI_From_Int - (Standard_Long_Long_Integer_Size); - -- We use this as the maximum machine scalar size in the sense of AI-133 - - Num_CC : Natural; - Comp : Entity_Id; - SSU : constant Uint := UI_From_Int (System_Storage_Unit); + Comp : Node_Id; + CC : Node_Id; begin - -- This first loop through components does two things. First it deals - -- with the case of components with component clauses whose length is - -- greater than the maximum machine scalar size (either accepting them - -- or rejecting as needed). Second, it counts the number of components - -- with component clauses whose length does not exceed this maximum for - -- later processing. - - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - declare - CC : constant Node_Id := Component_Clause (Comp); + -- Processing depends on version of Ada - begin - if Present (CC) then - declare - Fbit : constant Uint := Static_Integer (First_Bit (CC)); + case Ada_Version is - begin - -- Case of component with size > max machine scalar + -- For Ada 95, we just renumber bits within a storage unit. We do + -- the same for Ada 83 mode, since we recognize pragma Bit_Order + -- in Ada 83, and are free to add this extension. - if Esize (Comp) > Max_Machine_Scalar_Size then + when Ada_83 | Ada_95 => + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - -- Must begin on byte boundary + -- If component clause is present, then deal with the non- + -- default bit order case for Ada 95 mode. - if Fbit mod SSU /= 0 then - Error_Msg_N - ("illegal first bit value for reverse bit order", - First_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + -- We only do this processing for the base type, and in + -- fact that's important, since otherwise if there are + -- record subtypes, we could reverse the bits once for + -- each subtype, which would be incorrect. - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - First_Bit (CC)); + if Present (CC) + and then Ekind (R) = E_Record_Type + then + declare + CFB : constant Uint := Component_Bit_Offset (Comp); + CSZ : constant Uint := Esize (Comp); + CLC : constant Node_Id := Component_Clause (Comp); + Pos : constant Node_Id := Position (CLC); + FB : constant Node_Id := First_Bit (CLC); - -- Must end on byte boundary + Storage_Unit_Offset : constant Uint := + CFB / System_Storage_Unit; - elsif Esize (Comp) mod SSU /= 0 then - Error_Msg_N - ("illegal last bit value for reverse bit order", - Last_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + Start_Bit : constant Uint := + CFB mod System_Storage_Unit; - Error_Msg_N - ("\must be a multiple of ^ if size greater than ^", - Last_Bit (CC)); + begin + -- Cases where field goes over storage unit boundary - -- OK, give warning if enabled + if Start_Bit + CSZ > System_Storage_Unit then - elsif Warn_On_Reverse_Bit_Order then - Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CC); + -- Allow multi-byte field but generate warning - if Bytes_Big_Endian then + if Start_Bit mod System_Storage_Unit = 0 + and then CSZ mod System_Storage_Unit = 0 + then Error_Msg_N - ("\bytes are not reversed " - & "(component is big-endian)?", CC); + ("multi-byte field specified with non-standard" + & " Bit_Order?", CLC); + + if Bytes_Big_Endian then + Error_Msg_N + ("bytes are not reversed " + & "(component is big-endian)?", CLC); + else + Error_Msg_N + ("bytes are not reversed " + & "(component is little-endian)?", CLC); + end if; + + -- Do not allow non-contiguous field + else Error_Msg_N - ("\bytes are not reversed " - & "(component is little-endian)?", CC); + ("attempt to specify non-contiguous field " + & "not permitted", CLC); + Error_Msg_N + ("\caused by non-standard Bit_Order " + & "specified", CLC); + Error_Msg_N + ("\consider possibility of using " + & "Ada 2005 mode here", CLC); end if; - end if; - -- Case where size is not greater than max machine - -- scalar. For now, we just count these. + -- Case where field fits in one storage unit - else - Num_CC := Num_CC + 1; - end if; - end; - end if; - end; + else + -- Give warning if suspicious component clause - Next_Component_Or_Discriminant (Comp); - end loop; + if Intval (FB) >= System_Storage_Unit + and then Warn_On_Reverse_Bit_Order + then + Error_Msg_N + ("?Bit_Order clause does not affect " & + "byte ordering", Pos); + Error_Msg_Uint_1 := + Intval (Pos) + Intval (FB) / + System_Storage_Unit; + Error_Msg_N + ("?position normalized to ^ before bit " & + "order interpreted", Pos); + end if; - -- We need to sort the component clauses on the basis of the Position - -- values in the clause, so we can group clauses with the same Position. - -- together to determine the relevant machine scalar size. + -- Here is where we fix up the Component_Bit_Offset + -- value to account for the reverse bit order. + -- Some examples of what needs to be done are: - declare - Comps : array (0 .. Num_CC) of Entity_Id; - -- Array to collect component and discriminant entities. The data - -- starts at index 1, the 0'th entry is for the sort routine. + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new - function CP_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 - procedure CP_Move (From : Natural; To : Natural); - -- Move routine for Sort + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 - package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); + -- The general rule is that the first bit is + -- is obtained by subtracting the old ending bit + -- from storage_unit - 1. - Start : Natural; - Stop : Natural; - -- Start and stop positions in component list of set of components - -- with the same starting position (that constitute components in - -- a single machine scalar). + Set_Component_Bit_Offset + (Comp, + (Storage_Unit_Offset * System_Storage_Unit) + + (System_Storage_Unit - 1) - + (Start_Bit + CSZ - 1)); - MaxL : Uint; - -- Maximum last bit value of any component in this set + Set_Normalized_First_Bit + (Comp, + Component_Bit_Offset (Comp) mod + System_Storage_Unit); + end if; + end; + end if; - MSS : Uint; - -- Corresponding machine scalar size + Next_Component_Or_Discriminant (Comp); + end loop; - ----------- - -- CP_Lt -- - ----------- + -- For Ada 2005, we do machine scalar processing, as fully described + -- In AI-133. This involves gathering all components which start at + -- the same byte offset and processing them together - function CP_Lt (Op1, Op2 : Natural) return Boolean is - begin - return Position (Component_Clause (Comps (Op1))) < - Position (Component_Clause (Comps (Op2))); - end CP_Lt; + when Ada_05 .. Ada_Version_Type'Last => + declare + Max_Machine_Scalar_Size : constant Uint := + UI_From_Int + (Standard_Long_Long_Integer_Size); + -- We use this as the maximum machine scalar size - ------------- - -- CP_Move -- - ------------- + Num_CC : Natural; + SSU : constant Uint := UI_From_Int (System_Storage_Unit); - procedure CP_Move (From : Natural; To : Natural) is - begin - Comps (To) := Comps (From); - end CP_Move; + begin + -- This first loop through components does two things. First it + -- deals with the case of components with component clauses + -- whose length is greater than the maximum machine scalar size + -- (either accepting them or rejecting as needed). Second, it + -- counts the number of components with component clauses whose + -- length does not exceed this maximum for later processing. + + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - begin - -- Collect the component clauses + if Present (CC) then + declare + Fbit : constant Uint := + Static_Integer (First_Bit (CC)); - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - if Present (Component_Clause (Comp)) - and then Esize (Comp) <= Max_Machine_Scalar_Size - then - Num_CC := Num_CC + 1; - Comps (Num_CC) := Comp; - end if; + begin + -- Case of component with size > max machine scalar + + if Esize (Comp) > Max_Machine_Scalar_Size then + + -- Must begin on byte boundary + + if Fbit mod SSU /= 0 then + Error_Msg_N + ("illegal first bit value for " + & "reverse bit order", + First_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + + Error_Msg_N + ("\must be a multiple of ^ " + & "if size greater than ^", + First_Bit (CC)); + + -- Must end on byte boundary + + elsif Esize (Comp) mod SSU /= 0 then + Error_Msg_N + ("illegal last bit value for " + & "reverse bit order", + Last_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + + Error_Msg_N + ("\must be a multiple of ^ if size " + & "greater than ^", + Last_Bit (CC)); + + -- OK, give warning if enabled + + elsif Warn_On_Reverse_Bit_Order then + Error_Msg_N + ("multi-byte field specified with " + & " non-standard Bit_Order?", CC); + + if Bytes_Big_Endian then + Error_Msg_N + ("\bytes are not reversed " + & "(component is big-endian)?", CC); + else + Error_Msg_N + ("\bytes are not reversed " + & "(component is little-endian)?", CC); + end if; + end if; - Next_Component_Or_Discriminant (Comp); - end loop; + -- Case where size is not greater than max machine + -- scalar. For now, we just count these. - -- Sort by ascending position number - - Sorting.Sort (Num_CC); - - -- We now have all the components whose size does not exceed the max - -- machine scalar value, sorted by starting position. In this loop - -- we gather groups of clauses starting at the same position, to - -- process them in accordance with Ada 2005 AI-133. - - Stop := 0; - while Stop < Num_CC loop - Start := Stop + 1; - Stop := Start; - MaxL := - Static_Integer (Last_Bit (Component_Clause (Comps (Start)))); - while Stop < Num_CC loop - if Static_Integer - (Position (Component_Clause (Comps (Stop + 1)))) = - Static_Integer - (Position (Component_Clause (Comps (Stop)))) - then - Stop := Stop + 1; - MaxL := - UI_Max - (MaxL, - Static_Integer - (Last_Bit (Component_Clause (Comps (Stop))))); - else - exit; - end if; - end loop; + else + Num_CC := Num_CC + 1; + end if; + end; + end if; - -- Now we have a group of component clauses from Start to Stop - -- whose positions are identical, and MaxL is the maximum last bit - -- value of any of these components. + Next_Component_Or_Discriminant (Comp); + end loop; - -- We need to determine the corresponding machine scalar size. - -- This loop assumes that machine scalar sizes are even, and that - -- each possible machine scalar has twice as many bits as the - -- next smaller one. + -- We need to sort the component clauses on the basis of the + -- Position values in the clause, so we can group clauses with + -- the same Position. together to determine the relevant + -- machine scalar size. - MSS := Max_Machine_Scalar_Size; - while MSS mod 2 = 0 - and then (MSS / 2) >= SSU - and then (MSS / 2) > MaxL - loop - MSS := MSS / 2; - end loop; + Sort_CC : declare + Comps : array (0 .. Num_CC) of Entity_Id; + -- Array to collect component and discriminant entities. The + -- data starts at index 1, the 0'th entry is for the sort + -- routine. - -- Here is where we fix up the Component_Bit_Offset value to - -- account for the reverse bit order. Some examples of what needs - -- to be done for the case of a machine scalar size of 8 are: + function CP_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new + procedure CP_Move (From : Natural; To : Natural); + -- Move routine for Sort - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 + package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 + Start : Natural; + Stop : Natural; + -- Start and stop positions in component list of set of + -- components with the same starting position (that + -- constitute components in a single machine scalar). - -- The general rule is that the first bit is obtained by - -- subtracting the old ending bit from machine scalar size - 1. + MaxL : Uint; + -- Maximum last bit value of any component in this set - for C in Start .. Stop loop - declare - Comp : constant Entity_Id := Comps (C); - CC : constant Node_Id := Component_Clause (Comp); - LB : constant Uint := Static_Integer (Last_Bit (CC)); - NFB : constant Uint := MSS - Uint_1 - LB; - NLB : constant Uint := NFB + Esize (Comp) - 1; - Pos : constant Uint := Static_Integer (Position (CC)); + MSS : Uint; + -- Corresponding machine scalar size + + ----------- + -- CP_Lt -- + ----------- + + function CP_Lt (Op1, Op2 : Natural) return Boolean is + begin + return Position (Component_Clause (Comps (Op1))) < + Position (Component_Clause (Comps (Op2))); + end CP_Lt; + + ------------- + -- CP_Move -- + ------------- + + procedure CP_Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end CP_Move; + + -- Start of processing for Sort_CC begin - if Warn_On_Reverse_Bit_Order then - Error_Msg_Uint_1 := MSS; - Error_Msg_N - ("info: reverse bit order in machine " & - "scalar of length^?", First_Bit (CC)); - Error_Msg_Uint_1 := NFB; - Error_Msg_Uint_2 := NLB; + -- Collect the component clauses - if Bytes_Big_Endian then - Error_Msg_NE - ("?\info: big-endian range for " - & "component & is ^ .. ^", - First_Bit (CC), Comp); - else - Error_Msg_NE - ("?\info: little-endian range " - & "for component & is ^ .. ^", - First_Bit (CC), Comp); + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + if Present (Component_Clause (Comp)) + and then Esize (Comp) <= Max_Machine_Scalar_Size + then + Num_CC := Num_CC + 1; + Comps (Num_CC) := Comp; end if; - end if; - Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); - Set_Normalized_First_Bit (Comp, NFB mod SSU); - end; - end loop; - end loop; - end; + Next_Component_Or_Discriminant (Comp); + end loop; + + -- Sort by ascending position number + + Sorting.Sort (Num_CC); + + -- We now have all the components whose size does not exceed + -- the max machine scalar value, sorted by starting + -- position. In this loop we gather groups of clauses + -- starting at the same position, to process them in + -- accordance with Ada 2005 AI-133. + + Stop := 0; + while Stop < Num_CC loop + Start := Stop + 1; + Stop := Start; + MaxL := + Static_Integer + (Last_Bit (Component_Clause (Comps (Start)))); + while Stop < Num_CC loop + if Static_Integer + (Position (Component_Clause (Comps (Stop + 1)))) = + Static_Integer + (Position (Component_Clause (Comps (Stop)))) + then + Stop := Stop + 1; + MaxL := + UI_Max + (MaxL, + Static_Integer + (Last_Bit + (Component_Clause (Comps (Stop))))); + else + exit; + end if; + end loop; + + -- Now we have a group of component clauses from Start to + -- Stop whose positions are identical, and MaxL is the + -- maximum last bit value of any of these components. + + -- We need to determine the corresponding machine scalar + -- size. This loop assumes that machine scalar sizes are + -- even, and that each possible machine scalar has twice + -- as many bits as the next smaller one. + + MSS := Max_Machine_Scalar_Size; + while MSS mod 2 = 0 + and then (MSS / 2) >= SSU + and then (MSS / 2) > MaxL + loop + MSS := MSS / 2; + end loop; + + -- Here is where we fix up the Component_Bit_Offset value + -- to account for the reverse bit order. Some examples of + -- what needs to be done for the case of a machine scalar + -- size of 8 are: + + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new + + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 + + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 + + -- The general rule is that the first bit is obtained by + -- subtracting the old ending bit from machine scalar + -- size - 1. + + for C in Start .. Stop loop + declare + Comp : constant Entity_Id := Comps (C); + CC : constant Node_Id := + Component_Clause (Comp); + LB : constant Uint := + Static_Integer (Last_Bit (CC)); + NFB : constant Uint := MSS - Uint_1 - LB; + NLB : constant Uint := NFB + Esize (Comp) - 1; + Pos : constant Uint := + Static_Integer (Position (CC)); + + begin + if Warn_On_Reverse_Bit_Order then + Error_Msg_Uint_1 := MSS; + Error_Msg_N + ("info: reverse bit order in machine " & + "scalar of length^?", First_Bit (CC)); + Error_Msg_Uint_1 := NFB; + Error_Msg_Uint_2 := NLB; + + if Bytes_Big_Endian then + Error_Msg_NE + ("?\info: big-endian range for " + & "component & is ^ .. ^", + First_Bit (CC), Comp); + else + Error_Msg_NE + ("?\info: little-endian range " + & "for component & is ^ .. ^", + First_Bit (CC), Comp); + end if; + end if; + + Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_First_Bit (Comp, NFB mod SSU); + end; + end loop; + end loop; + end Sort_CC; + end; + end case; end Adjust_Record_For_Reverse_Bit_Order; -------------------------------------- @@ -704,7 +856,8 @@ package body Sem_Ch13 is Attribute_Write => null; - -- Other cases are errors, which will be caught below + -- Other cases are errors ("attribute& cannot be set with + -- definition clause"), which will be caught below. when others => null; @@ -803,9 +956,7 @@ package body Sem_Ch13 is -- it imported. if Ignore_Rep_Clauses then - if Ekind (U_Ent) = E_Variable - or else Ekind (U_Ent) = E_Constant - then + if Ekind_In (U_Ent, E_Variable, E_Constant) then Record_Rep_Item (U_Ent, N); end if; @@ -1534,8 +1685,8 @@ package body Sem_Ch13 is Nam); return; - elsif Ekind (U_Ent) /= E_Access_Type - and then Ekind (U_Ent) /= E_General_Access_Type + elsif not + Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) then Error_Msg_N ("storage pool can only be given for access types", Nam); @@ -1592,9 +1743,7 @@ package body Sem_Ch13 is if not Is_Entity_Name (Expr) and then Is_Object_Reference (Expr) then - Pool := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Pool := Make_Temporary (Loc, 'P', Expr); declare Rnode : constant Node_Id := @@ -1602,7 +1751,7 @@ package body Sem_Ch13 is Defining_Identifier => Pool, Subtype_Mark => New_Occurrence_Of (Etype (Expr), Loc), - Name => Expr); + Name => Expr); begin Insert_Before (N, Rnode); @@ -1662,8 +1811,7 @@ package body Sem_Ch13 is Error_Msg_N ("storage size clause for task is an " & "obsolescent feature (RM J.9)?", N); - Error_Msg_N - ("\use Storage_Size pragma instead?", N); + Error_Msg_N ("\use Storage_Size pragma instead?", N); end if; FOnly := True; @@ -2219,7 +2367,9 @@ package body Sem_Ch13 is -- code because their main purpose was to provide support to initialize -- the secondary dispatch tables. They are now generated also when -- compiling with no code generation to provide ASIS the relationship - -- between interface primitives and tagged type primitives. + -- between interface primitives and tagged type primitives. They are + -- also used to locate primitives covering interfaces when processing + -- generics (see Derive_Subprograms). if Ada_Version >= Ada_05 and then Ekind (E) = E_Record_Type @@ -2227,6 +2377,12 @@ package body Sem_Ch13 is and then not Is_Interface (E) and then Has_Interfaces (E) then + -- This would be a good common place to call the routine that checks + -- overriding of interface primitives (and thus factorize calls to + -- Check_Abstract_Overriding located at different contexts in the + -- compiler). However, this is not possible because it causes + -- spurious errors in case of late overriding. + Add_Internal_Interface_Entities (E); end if; end Analyze_Freeze_Entity; @@ -2235,11 +2391,16 @@ package body Sem_Ch13 is -- Analyze_Record_Representation_Clause -- ------------------------------------------ + -- Note: we check as much as we can here, but we can't do any checks + -- based on the position values (e.g. overlap checks) until freeze time + -- because especially in Ada 2005 (machine scalar mode), the processing + -- for non-standard bit order can substantially change the positions. + -- See procedure Check_Record_Representation_Clause (called from Freeze) + -- for the remainder of this processing. + procedure Analyze_Record_Representation_Clause (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); Ident : constant Node_Id := Identifier (N); Rectype : Entity_Id; - Fent : Entity_Id; CC : Node_Id; Posit : Uint; Fbit : Uint; @@ -2247,33 +2408,8 @@ package body Sem_Ch13 is Hbit : Uint := Uint_0; Comp : Entity_Id; Ocomp : Entity_Id; - Pcomp : Entity_Id; Biased : Boolean; - Max_Bit_So_Far : Uint; - -- Records the maximum bit position so far. If all field positions - -- are monotonically increasing, then we can skip the circuit for - -- checking for overlap, since no overlap is possible. - - Tagged_Parent : Entity_Id := Empty; - -- This is set in the case of a derived tagged type for which we have - -- Is_Fully_Repped_Tagged_Type True (indicating that all components are - -- positioned by record representation clauses). In this case we must - -- check for overlap between components of this tagged type, and the - -- components of its parent. Tagged_Parent will point to this parent - -- type. For all other cases Tagged_Parent is left set to Empty. - - Parent_Last_Bit : Uint; - -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the - -- last bit position for any field in the parent type. We only need to - -- check overlap for fields starting below this point. - - Overlap_Check_Required : Boolean; - -- Used to keep track of whether or not an overlap check is required - - Ccount : Natural := 0; - -- Number of component clauses in record rep clause - CR_Pragma : Node_Id := Empty; -- Points to N_Pragma node if Complete_Representation pragma present @@ -2370,7 +2506,6 @@ package body Sem_Ch13 is -- Get the alignment value to perform error checking Mod_Val := Get_Alignment_Value (Expression (M)); - end if; end; end if; @@ -2389,39 +2524,6 @@ package body Sem_Ch13 is end loop; end if; - -- See if we have a fully repped derived tagged type - - declare - PS : constant Entity_Id := Parent_Subtype (Rectype); - - begin - if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then - Tagged_Parent := PS; - - -- Find maximum bit of any component of the parent type - - Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if Ekind (Pcomp) = E_Discriminant - or else - Ekind (Pcomp) = E_Component - then - if Component_Bit_Offset (Pcomp) /= No_Uint - and then Known_Static_Esize (Pcomp) - then - Parent_Last_Bit := - UI_Max - (Parent_Last_Bit, - Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); - end if; - - Next_Entity (Pcomp); - end if; - end loop; - end if; - end; - -- All done if no component clauses CC := First (Component_Clauses (N)); @@ -2430,51 +2532,12 @@ package body Sem_Ch13 is return; end if; - -- If a tag is present, then create a component clause that places it - -- at the start of the record (otherwise gigi may place it after other - -- fields that have rep clauses). - - Fent := First_Entity (Rectype); - - if Nkind (Fent) = N_Defining_Identifier - and then Chars (Fent) = Name_uTag - then - Set_Component_Bit_Offset (Fent, Uint_0); - Set_Normalized_Position (Fent, Uint_0); - Set_Normalized_First_Bit (Fent, Uint_0); - Set_Normalized_Position_Max (Fent, Uint_0); - Init_Esize (Fent, System_Address_Size); - - Set_Component_Clause (Fent, - Make_Component_Clause (Loc, - Component_Name => - Make_Identifier (Loc, - Chars => Name_uTag), - - Position => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - First_Bit => - Make_Integer_Literal (Loc, - Intval => Uint_0), - - Last_Bit => - Make_Integer_Literal (Loc, - UI_From_Int (System_Address_Size)))); - - Ccount := Ccount + 1; - end if; - -- A representation like this applies to the base type Set_Has_Record_Rep_Clause (Base_Type (Rectype)); Set_Has_Non_Standard_Rep (Base_Type (Rectype)); Set_Has_Specified_Layout (Base_Type (Rectype)); - Max_Bit_So_Far := Uint_Minus_1; - Overlap_Check_Required := False; - -- Process the component clauses while Present (CC) loop @@ -2493,7 +2556,6 @@ package body Sem_Ch13 is -- Processing for real component clause else - Ccount := Ccount + 1; Posit := Static_Integer (Position (CC)); Fbit := Static_Integer (First_Bit (CC)); Lbit := Static_Integer (Last_Bit (CC)); @@ -2602,12 +2664,6 @@ package body Sem_Ch13 is Fbit := Fbit + UI_From_Int (SSU) * Posit; Lbit := Lbit + UI_From_Int (SSU) * Posit; - if Fbit <= Max_Bit_So_Far then - Overlap_Check_Required := True; - else - Max_Bit_So_Far := Lbit; - end if; - if Has_Size_Clause (Rectype) and then Esize (Rectype) <= Lbit then @@ -2621,17 +2677,6 @@ package body Sem_Ch13 is Set_Normalized_First_Bit (Comp, Fbit mod SSU); Set_Normalized_Position (Comp, Fbit / SSU); - Set_Normalized_Position_Max - (Fent, Normalized_Position (Fent)); - - if Is_Tagged_Type (Rectype) - and then Fbit < System_Address_Size - then - Error_Msg_NE - ("component overlaps tag field of&", - Component_Name (CC), Rectype); - end if; - -- This information is also set in the corresponding -- component of the base type, found by accessing the -- Original_Record_Component link if it is present. @@ -2674,27 +2719,6 @@ package body Sem_Ch13 is Error_Msg_N ("component size is negative", CC); end if; end if; - - -- If OK component size, check parent type overlap if - -- this component might overlap a parent field. - - if Present (Tagged_Parent) - and then Fbit <= Parent_Last_Bit - then - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if (Ekind (Pcomp) = E_Discriminant - or else - Ekind (Pcomp) = E_Component) - and then not Is_Tag (Pcomp) - and then Chars (Pcomp) /= Name_uParent - then - Check_Component_Overlap (Comp, Pcomp); - end if; - - Next_Entity (Pcomp); - end loop; - end if; end if; end if; end if; @@ -2703,254 +2727,6 @@ package body Sem_Ch13 is Next (CC); end loop; - -- Now that we have processed all the component clauses, check for - -- overlap. We have to leave this till last, since the components can - -- appear in any arbitrary order in the representation clause. - - -- We do not need this check if all specified ranges were monotonic, - -- as recorded by Overlap_Check_Required being False at this stage. - - -- This first section checks if there are any overlapping entries at - -- all. It does this by sorting all entries and then seeing if there are - -- any overlaps. If there are none, then that is decisive, but if there - -- are overlaps, they may still be OK (they may result from fields in - -- different variants). - - if Overlap_Check_Required then - Overlap_Check1 : declare - - OC_Fbit : array (0 .. Ccount) of Uint; - -- First-bit values for component clauses, the value is the offset - -- of the first bit of the field from start of record. The zero - -- entry is for use in sorting. - - OC_Lbit : array (0 .. Ccount) of Uint; - -- Last-bit values for component clauses, the value is the offset - -- of the last bit of the field from start of record. The zero - -- entry is for use in sorting. - - OC_Count : Natural := 0; - -- Count of entries in OC_Fbit and OC_Lbit - - function OC_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort - - procedure OC_Move (From : Natural; To : Natural); - -- Move routine for Sort - - package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); - - ----------- - -- OC_Lt -- - ----------- - - function OC_Lt (Op1, Op2 : Natural) return Boolean is - begin - return OC_Fbit (Op1) < OC_Fbit (Op2); - end OC_Lt; - - ------------- - -- OC_Move -- - ------------- - - procedure OC_Move (From : Natural; To : Natural) is - begin - OC_Fbit (To) := OC_Fbit (From); - OC_Lbit (To) := OC_Lbit (From); - end OC_Move; - - -- Start of processing for Overlap_Check - - begin - CC := First (Component_Clauses (N)); - while Present (CC) loop - if Nkind (CC) /= N_Pragma then - Posit := Static_Integer (Position (CC)); - Fbit := Static_Integer (First_Bit (CC)); - Lbit := Static_Integer (Last_Bit (CC)); - - if Posit /= No_Uint - and then Fbit /= No_Uint - and then Lbit /= No_Uint - then - OC_Count := OC_Count + 1; - Posit := Posit * SSU; - OC_Fbit (OC_Count) := Fbit + Posit; - OC_Lbit (OC_Count) := Lbit + Posit; - end if; - end if; - - Next (CC); - end loop; - - Sorting.Sort (OC_Count); - - Overlap_Check_Required := False; - for J in 1 .. OC_Count - 1 loop - if OC_Lbit (J) >= OC_Fbit (J + 1) then - Overlap_Check_Required := True; - exit; - end if; - end loop; - end Overlap_Check1; - end if; - - -- If Overlap_Check_Required is still True, then we have to do the full - -- scale overlap check, since we have at least two fields that do - -- overlap, and we need to know if that is OK since they are in - -- different variant, or whether we have a definite problem. - - if Overlap_Check_Required then - Overlap_Check2 : declare - C1_Ent, C2_Ent : Entity_Id; - -- Entities of components being checked for overlap - - Clist : Node_Id; - -- Component_List node whose Component_Items are being checked - - Citem : Node_Id; - -- Component declaration for component being checked - - begin - C1_Ent := First_Entity (Base_Type (Rectype)); - - -- Loop through all components in record. For each component check - -- for overlap with any of the preceding elements on the component - -- list containing the component and also, if the component is in - -- a variant, check against components outside the case structure. - -- This latter test is repeated recursively up the variant tree. - - Main_Component_Loop : while Present (C1_Ent) loop - if Ekind (C1_Ent) /= E_Component - and then Ekind (C1_Ent) /= E_Discriminant - then - goto Continue_Main_Component_Loop; - end if; - - -- Skip overlap check if entity has no declaration node. This - -- happens with discriminants in constrained derived types. - -- Probably we are missing some checks as a result, but that - -- does not seem terribly serious ??? - - if No (Declaration_Node (C1_Ent)) then - goto Continue_Main_Component_Loop; - end if; - - Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); - - -- Loop through component lists that need checking. Check the - -- current component list and all lists in variants above us. - - Component_List_Loop : loop - - -- If derived type definition, go to full declaration - -- If at outer level, check discriminants if there are any. - - if Nkind (Clist) = N_Derived_Type_Definition then - Clist := Parent (Clist); - end if; - - -- Outer level of record definition, check discriminants - - if Nkind_In (Clist, N_Full_Type_Declaration, - N_Private_Type_Declaration) - then - if Has_Discriminants (Defining_Identifier (Clist)) then - C2_Ent := - First_Discriminant (Defining_Identifier (Clist)); - while Present (C2_Ent) loop - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - Next_Discriminant (C2_Ent); - end loop; - end if; - - -- Record extension case - - elsif Nkind (Clist) = N_Derived_Type_Definition then - Clist := Empty; - - -- Otherwise check one component list - - else - Citem := First (Component_Items (Clist)); - - while Present (Citem) loop - if Nkind (Citem) = N_Component_Declaration then - C2_Ent := Defining_Identifier (Citem); - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - end if; - - Next (Citem); - end loop; - end if; - - -- Check for variants above us (the parent of the Clist can - -- be a variant, in which case its parent is a variant part, - -- and the parent of the variant part is a component list - -- whose components must all be checked against the current - -- component for overlap). - - if Nkind (Parent (Clist)) = N_Variant then - Clist := Parent (Parent (Parent (Clist))); - - -- Check for possible discriminant part in record, this is - -- treated essentially as another level in the recursion. - -- For this case the parent of the component list is the - -- record definition, and its parent is the full type - -- declaration containing the discriminant specifications. - - elsif Nkind (Parent (Clist)) = N_Record_Definition then - Clist := Parent (Parent ((Clist))); - - -- If neither of these two cases, we are at the top of - -- the tree. - - else - exit Component_List_Loop; - end if; - end loop Component_List_Loop; - - <<Continue_Main_Component_Loop>> - Next_Entity (C1_Ent); - - end loop Main_Component_Loop; - end Overlap_Check2; - end if; - - -- For records that have component clauses for all components, and whose - -- size is less than or equal to 32, we need to know the size in the - -- front end to activate possible packed array processing where the - -- component type is a record. - - -- At this stage Hbit + 1 represents the first unused bit from all the - -- component clauses processed, so if the component clauses are - -- complete, then this is the length of the record. - - -- For records longer than System.Storage_Unit, and for those where not - -- all components have component clauses, the back end determines the - -- length (it may for example be appropriate to round up the size - -- to some convenient boundary, based on alignment considerations, etc). - - if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then - - -- Nothing to do if at least one component has no component clause - - Comp := First_Component_Or_Discriminant (Rectype); - while Present (Comp) loop - exit when No (Component_Clause (Comp)); - Next_Component_Or_Discriminant (Comp); - end loop; - - -- If we fall out of loop, all components have component clauses - -- and so we can set the size to the maximum value. - - if No (Comp) then - Set_RM_Size (Rectype, Hbit + 1); - end if; - end if; - -- Check missing components if Complete_Representation pragma appeared if Present (CR_Pragma) then @@ -2964,7 +2740,7 @@ package body Sem_Ch13 is Next_Component_Or_Discriminant (Comp); end loop; - -- If no Complete_Representation pragma, warn if missing components + -- If no Complete_Representation pragma, warn if missing components elsif Warn_On_Unrepped_Components then declare @@ -3002,8 +2778,8 @@ package body Sem_Ch13 is and then Comes_From_Source (Comp) and then Present (Underlying_Type (Etype (Comp))) and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) - or else Size_Known_At_Compile_Time - (Underlying_Type (Etype (Comp)))) + or else Size_Known_At_Compile_Time + (Underlying_Type (Etype (Comp)))) and then not Has_Warnings_Off (Rectype) then Error_Msg_Sloc := Sloc (Comp); @@ -3019,50 +2795,6 @@ package body Sem_Ch13 is end if; end Analyze_Record_Representation_Clause; - ----------------------------- - -- Check_Component_Overlap -- - ----------------------------- - - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is - begin - if Present (Component_Clause (C1_Ent)) - and then Present (Component_Clause (C2_Ent)) - then - -- Exclude odd case where we have two tag fields in the same record, - -- both at location zero. This seems a bit strange, but it seems to - -- happen in some circumstances ??? - - if Chars (C1_Ent) = Name_uTag - and then Chars (C2_Ent) = Name_uTag - then - return; - end if; - - -- Here we check if the two fields overlap - - declare - S1 : constant Uint := Component_Bit_Offset (C1_Ent); - S2 : constant Uint := Component_Bit_Offset (C2_Ent); - E1 : constant Uint := S1 + Esize (C1_Ent); - E2 : constant Uint := S2 + Esize (C2_Ent); - - begin - if E2 <= S1 or else E1 <= S2 then - null; - else - Error_Msg_Node_2 := - Component_Name (Component_Clause (C2_Ent)); - Error_Msg_Sloc := Sloc (Error_Msg_Node_2); - Error_Msg_Node_1 := - Component_Name (Component_Clause (C1_Ent)); - Error_Msg_N - ("component& overlaps & #", - Component_Name (Component_Clause (C1_Ent))); - end if; - end; - end if; - end Check_Component_Overlap; - ----------------------------------- -- Check_Constant_Address_Clause -- ----------------------------------- @@ -3209,11 +2941,8 @@ package body Sem_Ch13 is -- Otherwise look at the identifier and see if it is OK - if Ekind (Ent) = E_Named_Integer - or else - Ekind (Ent) = E_Named_Real - or else - Is_Type (Ent) + if Ekind_In (Ent, E_Named_Integer, E_Named_Real) + or else Is_Type (Ent) then return; @@ -3409,9 +3138,576 @@ package body Sem_Ch13 is -- Start of processing for Check_Constant_Address_Clause begin - Check_Expr_Constants (Expr); + -- If rep_clauses are to be ignored, no need for legality checks. In + -- particular, no need to pester user about rep clauses that violate + -- the rule on constant addresses, given that these clauses will be + -- removed by Freeze before they reach the back end. + + if not Ignore_Rep_Clauses then + Check_Expr_Constants (Expr); + end if; end Check_Constant_Address_Clause; + ---------------------------------------- + -- Check_Record_Representation_Clause -- + ---------------------------------------- + + procedure Check_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ident : constant Node_Id := Identifier (N); + Rectype : Entity_Id; + Fent : Entity_Id; + CC : Node_Id; + Fbit : Uint; + Lbit : Uint; + Hbit : Uint := Uint_0; + Comp : Entity_Id; + Pcomp : Entity_Id; + + Max_Bit_So_Far : Uint; + -- Records the maximum bit position so far. If all field positions + -- are monotonically increasing, then we can skip the circuit for + -- checking for overlap, since no overlap is possible. + + Tagged_Parent : Entity_Id := Empty; + -- This is set in the case of a derived tagged type for which we have + -- Is_Fully_Repped_Tagged_Type True (indicating that all components are + -- positioned by record representation clauses). In this case we must + -- check for overlap between components of this tagged type, and the + -- components of its parent. Tagged_Parent will point to this parent + -- type. For all other cases Tagged_Parent is left set to Empty. + + Parent_Last_Bit : Uint; + -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the + -- last bit position for any field in the parent type. We only need to + -- check overlap for fields starting below this point. + + Overlap_Check_Required : Boolean; + -- Used to keep track of whether or not an overlap check is required + + Ccount : Natural := 0; + -- Number of component clauses in record rep clause + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); + -- Given two entities for record components or discriminants, checks + -- if they have overlapping component clauses and issues errors if so. + + procedure Find_Component; + -- Finds component entity corresponding to current component clause (in + -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin + -- start/stop bits for the field. If there is no matching component or + -- if the matching component does not have a component clause, then + -- that's an error and Comp is set to Empty, but no error message is + -- issued, since the message was already given. Comp is also set to + -- Empty if the current "component clause" is in fact a pragma. + + ----------------------------- + -- Check_Component_Overlap -- + ----------------------------- + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is + CC1 : constant Node_Id := Component_Clause (C1_Ent); + CC2 : constant Node_Id := Component_Clause (C2_Ent); + begin + if Present (CC1) and then Present (CC2) then + + -- Exclude odd case where we have two tag fields in the same + -- record, both at location zero. This seems a bit strange, but + -- it seems to happen in some circumstances, perhaps on an error. + + if Chars (C1_Ent) = Name_uTag + and then + Chars (C2_Ent) = Name_uTag + then + return; + end if; + + -- Here we check if the two fields overlap + + declare + S1 : constant Uint := Component_Bit_Offset (C1_Ent); + S2 : constant Uint := Component_Bit_Offset (C2_Ent); + E1 : constant Uint := S1 + Esize (C1_Ent); + E2 : constant Uint := S2 + Esize (C2_Ent); + + begin + if E2 <= S1 or else E1 <= S2 then + null; + else + Error_Msg_Node_2 := Component_Name (CC2); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_Node_1 := Component_Name (CC1); + Error_Msg_N + ("component& overlaps & #", Component_Name (CC1)); + end if; + end; + end if; + end Check_Component_Overlap; + + -------------------- + -- Find_Component -- + -------------------- + + procedure Find_Component is + + procedure Search_Component (R : Entity_Id); + -- Search components of R for a match. If found, Comp is set. + + ---------------------- + -- Search_Component -- + ---------------------- + + procedure Search_Component (R : Entity_Id) is + begin + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + + -- Ignore error of attribute name for component name (we + -- already gave an error message for this, so no need to + -- complain here) + + if Nkind (Component_Name (CC)) = N_Attribute_Reference then + null; + else + exit when Chars (Comp) = Chars (Component_Name (CC)); + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end Search_Component; + + -- Start of processing for Find_Component + + begin + -- Return with Comp set to Empty if we have a pragma + + if Nkind (CC) = N_Pragma then + Comp := Empty; + return; + end if; + + -- Search current record for matching component + + Search_Component (Rectype); + + -- If not found, maybe component of base type that is absent from + -- statically constrained first subtype. + + if No (Comp) then + Search_Component (Base_Type (Rectype)); + end if; + + -- If no component, or the component does not reference the component + -- clause in question, then there was some previous error for which + -- we already gave a message, so just return with Comp Empty. + + if No (Comp) + or else Component_Clause (Comp) /= CC + then + Comp := Empty; + + -- Normal case where we have a component clause + + else + Fbit := Component_Bit_Offset (Comp); + Lbit := Fbit + Esize (Comp) - 1; + end if; + end Find_Component; + + -- Start of processing for Check_Record_Representation_Clause + + begin + Find_Type (Ident); + Rectype := Entity (Ident); + + if Rectype = Any_Type then + return; + else + Rectype := Underlying_Type (Rectype); + end if; + + -- See if we have a fully repped derived tagged type + + declare + PS : constant Entity_Id := Parent_Subtype (Rectype); + + begin + if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then + Tagged_Parent := PS; + + -- Find maximum bit of any component of the parent type + + Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); + Pcomp := First_Entity (Tagged_Parent); + while Present (Pcomp) loop + if Ekind_In (Pcomp, E_Discriminant, E_Component) then + if Component_Bit_Offset (Pcomp) /= No_Uint + and then Known_Static_Esize (Pcomp) + then + Parent_Last_Bit := + UI_Max + (Parent_Last_Bit, + Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); + end if; + + Next_Entity (Pcomp); + end if; + end loop; + end if; + end; + + -- All done if no component clauses + + CC := First (Component_Clauses (N)); + + if No (CC) then + return; + end if; + + -- If a tag is present, then create a component clause that places it + -- at the start of the record (otherwise gigi may place it after other + -- fields that have rep clauses). + + Fent := First_Entity (Rectype); + + if Nkind (Fent) = N_Defining_Identifier + and then Chars (Fent) = Name_uTag + then + Set_Component_Bit_Offset (Fent, Uint_0); + Set_Normalized_Position (Fent, Uint_0); + Set_Normalized_First_Bit (Fent, Uint_0); + Set_Normalized_Position_Max (Fent, Uint_0); + Init_Esize (Fent, System_Address_Size); + + Set_Component_Clause (Fent, + Make_Component_Clause (Loc, + Component_Name => + Make_Identifier (Loc, + Chars => Name_uTag), + + Position => + Make_Integer_Literal (Loc, + Intval => Uint_0), + + First_Bit => + Make_Integer_Literal (Loc, + Intval => Uint_0), + + Last_Bit => + Make_Integer_Literal (Loc, + UI_From_Int (System_Address_Size)))); + + Ccount := Ccount + 1; + end if; + + Max_Bit_So_Far := Uint_Minus_1; + Overlap_Check_Required := False; + + -- Process the component clauses + + while Present (CC) loop + Find_Component; + + if Present (Comp) then + Ccount := Ccount + 1; + + if Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + else + Max_Bit_So_Far := Lbit; + end if; + + -- Check bit position out of range of specified size + + if Has_Size_Clause (Rectype) + and then Esize (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); + + -- Check for overlap with tag field + + else + if Is_Tagged_Type (Rectype) + and then Fbit < System_Address_Size + then + Error_Msg_NE + ("component overlaps tag field of&", + Component_Name (CC), Rectype); + end if; + + if Hbit < Lbit then + Hbit := Lbit; + end if; + end if; + + -- Check parent overlap if component might overlap parent field + + if Present (Tagged_Parent) + and then Fbit <= Parent_Last_Bit + then + Pcomp := First_Component_Or_Discriminant (Tagged_Parent); + while Present (Pcomp) loop + if not Is_Tag (Pcomp) + and then Chars (Pcomp) /= Name_uParent + then + Check_Component_Overlap (Comp, Pcomp); + end if; + + Next_Component_Or_Discriminant (Pcomp); + end loop; + end if; + end if; + + Next (CC); + end loop; + + -- Now that we have processed all the component clauses, check for + -- overlap. We have to leave this till last, since the components can + -- appear in any arbitrary order in the representation clause. + + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. + + -- This first section checks if there are any overlapping entries at + -- all. It does this by sorting all entries and then seeing if there are + -- any overlaps. If there are none, then that is decisive, but if there + -- are overlaps, they may still be OK (they may result from fields in + -- different variants). + + if Overlap_Check_Required then + Overlap_Check1 : declare + + OC_Fbit : array (0 .. Ccount) of Uint; + -- First-bit values for component clauses, the value is the offset + -- of the first bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Lbit : array (0 .. Ccount) of Uint; + -- Last-bit values for component clauses, the value is the offset + -- of the last bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit + + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); + + ----------- + -- OC_Lt -- + ----------- + + function OC_Lt (Op1, Op2 : Natural) return Boolean is + begin + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; + + ------------- + -- OC_Move -- + ------------- + + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; + + -- Start of processing for Overlap_Check + + begin + CC := First (Component_Clauses (N)); + while Present (CC) loop + + -- Exclude component clause already marked in error + + if not Error_Posted (CC) then + Find_Component; + + if Present (Comp) then + OC_Count := OC_Count + 1; + OC_Fbit (OC_Count) := Fbit; + OC_Lbit (OC_Count) := Lbit; + end if; + end if; + + Next (CC); + end loop; + + Sorting.Sort (OC_Count); + + Overlap_Check_Required := False; + for J in 1 .. OC_Count - 1 loop + if OC_Lbit (J) >= OC_Fbit (J + 1) then + Overlap_Check_Required := True; + exit; + end if; + end loop; + end Overlap_Check1; + end if; + + -- If Overlap_Check_Required is still True, then we have to do the full + -- scale overlap check, since we have at least two fields that do + -- overlap, and we need to know if that is OK since they are in + -- different variant, or whether we have a definite problem. + + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap + + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked + + Citem : Node_Id; + -- Component declaration for component being checked + + begin + C1_Ent := First_Entity (Base_Type (Rectype)); + + -- Loop through all components in record. For each component check + -- for overlap with any of the preceding elements on the component + -- list containing the component and also, if the component is in + -- a variant, check against components outside the case structure. + -- This latter test is repeated recursively up the variant tree. + + Main_Component_Loop : while Present (C1_Ent) loop + if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then + goto Continue_Main_Component_Loop; + end if; + + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Probably we are missing some checks as a result, but that + -- does not seem terribly serious ??? + + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; + end if; + + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); + + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. + + Component_List_Loop : loop + + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. + + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; + + -- Outer level of record definition, check discriminants + + if Nkind_In (Clist, N_Full_Type_Declaration, + N_Private_Type_Declaration) + then + if Has_Discriminants (Defining_Identifier (Clist)) then + C2_Ent := + First_Discriminant (Defining_Identifier (Clist)); + while Present (C2_Ent) loop + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + Next_Discriminant (C2_Ent); + end loop; + end if; + + -- Record extension case + + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; + + -- Otherwise check one component list + + else + Citem := First (Component_Items (Clist)); + + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + C2_Ent := Defining_Identifier (Citem); + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + end if; + + Next (Citem); + end loop; + end if; + + -- Check for variants above us (the parent of the Clist can + -- be a variant, in which case its parent is a variant part, + -- and the parent of the variant part is a component list + -- whose components must all be checked against the current + -- component for overlap). + + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); + + -- Check for possible discriminant part in record, this + -- is treated essentially as another level in the + -- recursion. For this case the parent of the component + -- list is the record definition, and its parent is the + -- full type declaration containing the discriminant + -- specifications. + + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); + + -- If neither of these two cases, we are at the top of + -- the tree. + + else + exit Component_List_Loop; + end if; + end loop Component_List_Loop; + + <<Continue_Main_Component_Loop>> + Next_Entity (C1_Ent); + + end loop Main_Component_Loop; + end Overlap_Check2; + end if; + + -- For records that have component clauses for all components, and whose + -- size is less than or equal to 32, we need to know the size in the + -- front end to activate possible packed array processing where the + -- component type is a record. + + -- At this stage Hbit + 1 represents the first unused bit from all the + -- component clauses processed, so if the component clauses are + -- complete, then this is the length of the record. + + -- For records longer than System.Storage_Unit, and for those where not + -- all components have component clauses, the back end determines the + -- length (it may for example be appropriate to round up the size + -- to some convenient boundary, based on alignment considerations, etc). + + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then + + -- Nothing to do if at least one component has no component clause + + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + exit when No (Component_Clause (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; + + -- If we fall out of loop, all components have component clauses + -- and so we can set the size to the maximum value. + + if No (Comp) then + Set_RM_Size (Rectype, Hbit + 1); + end if; + end if; + end Check_Record_Representation_Clause; + ---------------- -- Check_Size -- ---------------- @@ -3885,9 +4181,10 @@ package body Sem_Ch13 is Out_Present => Out_P, Parameter_Type => T_Ref)); - Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => Formals); + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals); end if; return Spec; @@ -3961,8 +4258,7 @@ package body Sem_Ch13 is elsif Is_Type (T) and then Is_Generic_Type (Root_Type (T)) then - Error_Msg_N - ("representation item not allowed for generic type", N); + Error_Msg_N ("representation item not allowed for generic type", N); return True; end if; diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 93587fd38d2..b95eed60a92 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -38,9 +38,17 @@ package Sem_Ch13 is procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id); -- Called from Freeze where R is a record entity for which reverse bit -- order is specified and there is at least one component clause. Adjusts - -- component positions according to Ada 2005 AI-133. Note that this is only - -- called in Ada 2005 mode. The Ada 95 handling for bit order is entirely - -- contained in Freeze. + -- component positions according to either Ada 95 or Ada 2005 (AI-133). + + procedure Check_Record_Representation_Clause (N : Node_Id); + -- This procedure completes the analysis of a record representation clause + -- N. It is called at freeze time after adjustment of component clause bit + -- positions for possible non-standard bit order. In the case of Ada 2005 + -- (machine scalar) mode, this adjustment can make substantial changes, so + -- some checks, in particular for component overlaps cannot be done at the + -- time the record representation clause is first seen, but must be delayed + -- till freeze time, and in particular is called after calling the above + -- procedure for adjusting record bit positions for reverse bit order. procedure Initialize; -- Initialize internal tables for new compilation diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6e0efe1fd30..d5b39f99f9d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -68,6 +68,7 @@ with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Targparm; use Targparm; with Tbuild; use Tbuild; @@ -1037,8 +1038,8 @@ package body Sem_Ch3 is begin -- Associate the Itype node with the inner full-type declaration or - -- subprogram spec. This is required to handle nested anonymous - -- declarations. For example: + -- subprogram spec or entry body. This is required to handle nested + -- anonymous declarations. For example: -- procedure P -- (X : access procedure @@ -1050,7 +1051,9 @@ package body Sem_Ch3 is N_Private_Type_Declaration, N_Private_Extension_Declaration, N_Procedure_Specification, - N_Function_Specification) + N_Function_Specification, + N_Entry_Body) + or else Nkind_In (D_Ityp, N_Object_Declaration, N_Object_Renaming_Declaration, @@ -1364,7 +1367,7 @@ package body Sem_Ch3 is Subtype_Indication => New_Occurrence_Of (RTE (RE_Interface_Tag), Loc)); - Tag := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + Tag := Make_Temporary (Loc, 'V'); Decl := Make_Component_Declaration (Loc, @@ -1406,8 +1409,7 @@ package body Sem_Ch3 is Subtype_Indication => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); - Offset := - Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + Offset := Make_Temporary (Loc, 'V'); Decl := Make_Component_Declaration (Loc, @@ -1515,13 +1517,14 @@ package body Sem_Ch3 is ------------------------------------- procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; - Iface_Prim : Entity_Id; - Ifaces_List : Elist_Id; - New_Subp : Entity_Id := Empty; - Prim : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; + Ifaces_List : Elist_Id; + New_Subp : Entity_Id := Empty; + Prim : Entity_Id; + Restore_Scope : Boolean := False; begin pragma Assert (Ada_Version >= Ada_05 @@ -1530,74 +1533,127 @@ package body Sem_Ch3 is and then Has_Interfaces (Tagged_Type) and then not Is_Interface (Tagged_Type)); + -- Ensure that the internal entities are added to the scope of the type + + if Scope (Tagged_Type) /= Current_Scope then + Push_Scope (Scope (Tagged_Type)); + Restore_Scope := True; + end if; + Collect_Interfaces (Tagged_Type, Ifaces_List); Iface_Elmt := First_Elmt (Ifaces_List); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); - -- Exclude from this processing interfaces that are parents of - -- Tagged_Type because their primitives are located in the primary - -- dispatch table (and hence no auxiliary internal entities are - -- required to handle secondary dispatch tables in such case). + -- Originally we excluded here from this processing interfaces that + -- are parents of Tagged_Type because their primitives are located + -- in the primary dispatch table (and hence no auxiliary internal + -- entities are required to handle secondary dispatch tables in such + -- case). However, these auxiliary entities are also required to + -- handle derivations of interfaces in formals of generics (see + -- Derive_Subprograms). - if not Is_Ancestor (Iface, Tagged_Type) then - Elmt := First_Elmt (Primitive_Operations (Iface)); - while Present (Elmt) loop - Iface_Prim := Node (Elmt); + Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Elmt) loop + Iface_Prim := Node (Elmt); - if not Is_Predefined_Dispatching_Operation (Iface_Prim) then - Prim := - Find_Primitive_Covering_Interface - (Tagged_Type => Tagged_Type, - Iface_Prim => Iface_Prim); - - pragma Assert (Present (Prim)); - - Derive_Subprogram - (New_Subp => New_Subp, - Parent_Subp => Iface_Prim, - Derived_Type => Tagged_Type, - Parent_Type => Iface); - - -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp - -- associated with interface types. These entities are - -- only registered in the list of primitives of its - -- corresponding tagged type because they are only used - -- to fill the contents of the secondary dispatch tables. - -- Therefore they are removed from the homonym chains. - - Set_Is_Hidden (New_Subp); - Set_Is_Internal (New_Subp); - Set_Alias (New_Subp, Prim); - Set_Is_Abstract_Subprogram (New_Subp, - Is_Abstract_Subprogram (Prim)); - Set_Interface_Alias (New_Subp, Iface_Prim); - - -- Internal entities associated with interface types are - -- only registered in the list of primitives of the tagged - -- type. They are only used to fill the contents of the - -- secondary dispatch tables. Therefore they are not needed - -- in the homonym chains. - - Remove_Homonym (New_Subp); - - -- Hidden entities associated with interfaces must have set - -- the Has_Delay_Freeze attribute to ensure that, in case of - -- locally defined tagged types (or compiling with static - -- dispatch tables generation disabled) the corresponding - -- entry of the secondary dispatch table is filled when - -- such an entity is frozen. - - Set_Has_Delayed_Freeze (New_Subp); + if not Is_Predefined_Dispatching_Operation (Iface_Prim) then + Prim := + Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Prim); + + -- Handle cases where the type has no primitive covering this + -- interface primitive. + + if No (Prim) then + + -- if the tagged type is defined at library level then we + -- invoke Check_Abstract_Overriding to report the error + -- and thus avoid generating the dispatch tables. + + if Is_Library_Level_Tagged_Type (Tagged_Type) then + Check_Abstract_Overriding (Tagged_Type); + pragma Assert (Serious_Errors_Detected > 0); + return; + + -- For tagged types defined in nested scopes it is still + -- possible to cover this interface primitive by means of + -- late overriding (see Override_Dispatching_Operation). + + -- Search in the list of primitives of the type for the + -- entity that will be overridden in such case to reference + -- it in the internal entity that we build here. If the + -- primitive is not overridden then the error will be + -- reported later as part of the analysis of entities + -- defined in the enclosing scope. + + else + declare + El : Elmt_Id; + + begin + El := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (El) + and then Alias (Node (El)) /= Iface_Prim + loop + Next_Elmt (El); + end loop; + + pragma Assert (Present (El)); + Prim := Node (El); + end; + end if; end if; - Next_Elmt (Elmt); - end loop; - end if; + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Iface_Prim, + Derived_Type => Tagged_Type, + Parent_Type => Iface); + + -- Ada 2005 (AI-251): Decorate internal entity Iface_Subp + -- associated with interface types. These entities are + -- only registered in the list of primitives of its + -- corresponding tagged type because they are only used + -- to fill the contents of the secondary dispatch tables. + -- Therefore they are removed from the homonym chains. + + Set_Is_Hidden (New_Subp); + Set_Is_Internal (New_Subp); + Set_Alias (New_Subp, Prim); + Set_Is_Abstract_Subprogram + (New_Subp, Is_Abstract_Subprogram (Prim)); + Set_Interface_Alias (New_Subp, Iface_Prim); + + -- Internal entities associated with interface types are + -- only registered in the list of primitives of the tagged + -- type. They are only used to fill the contents of the + -- secondary dispatch tables. Therefore they are not needed + -- in the homonym chains. + + Remove_Homonym (New_Subp); + + -- Hidden entities associated with interfaces must have set + -- the Has_Delay_Freeze attribute to ensure that, in case of + -- locally defined tagged types (or compiling with static + -- dispatch tables generation disabled) the corresponding + -- entry of the secondary dispatch table is filled when + -- such an entity is frozen. + + Set_Has_Delayed_Freeze (New_Subp); + end if; + + Next_Elmt (Elmt); + end loop; Next_Elmt (Iface_Elmt); end loop; + + if Restore_Scope then + Pop_Scope; + end if; end Add_Internal_Interface_Entities; ----------------------------------- @@ -1913,8 +1969,7 @@ package body Sem_Ch3 is if Is_Interface (Root_Type (Current_Scope)) then Error_Msg_N ("\limitedness is not inherited from limited interface", N); - Error_Msg_N - ("\add LIMITED to type indication", N); + Error_Msg_N ("\add LIMITED to type indication", N); end if; Explain_Limited_Type (T, N); @@ -2141,17 +2196,6 @@ package body Sem_Ch3 is or else Synchronized_Present (Def) or else Task_Present (Def)); - Set_Is_Protected_Interface (T, Protected_Present (Def)); - Set_Is_Task_Interface (T, Task_Present (Def)); - - -- Type is a synchronized interface if it includes the keyword task, - -- protected, or synchronized. - - Set_Is_Synchronized_Interface - (T, Synchronized_Present (Def) - or else Protected_Present (Def) - or else Task_Present (Def)); - Set_Interfaces (T, New_Elmt_List); Set_Primitive_Operations (T, New_Elmt_List); @@ -2161,9 +2205,6 @@ package body Sem_Ch3 is if Present (CW) then Set_Is_Interface (CW); Set_Is_Limited_Interface (CW, Is_Limited_Interface (T)); - Set_Is_Protected_Interface (CW, Is_Protected_Interface (T)); - Set_Is_Synchronized_Interface (CW, Is_Synchronized_Interface (T)); - Set_Is_Task_Interface (CW, Is_Task_Interface (T)); end if; -- Check runtime support for synchronized interfaces @@ -3285,9 +3326,7 @@ package body Sem_Ch3 is ("parent of type extension must be a tagged type ", Indic); return; - elsif Ekind (Parent_Type) = E_Void - or else Ekind (Parent_Type) = E_Incomplete_Type - then + elsif Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then Error_Msg_N ("premature derivation of incomplete type", Indic); return; @@ -4325,9 +4364,7 @@ package body Sem_Ch3 is Decl : Entity_Id; begin - New_E := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + New_E := Make_Temporary (Loc, 'T'); Set_Is_Internal (New_E); Decl := @@ -4576,10 +4613,7 @@ package body Sem_Ch3 is Curr_Scope : constant Scope_Stack_Entry := Scope_Stack.Table (Scope_Stack.Last); - Anon : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - + Anon : constant Entity_Id := Make_Temporary (Loc, 'S'); Acc : Node_Id; Comp : Node_Id; Decl : Node_Id; @@ -4921,9 +4955,7 @@ package body Sem_Ch3 is is Loc : constant Source_Ptr := Sloc (N); - Corr_Record : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - + Corr_Record : constant Entity_Id := Make_Temporary (Loc, 'C'); Corr_Decl : Node_Id; Corr_Decl_Needed : Boolean; -- If the derived type has fewer discriminants than its parent, the @@ -5726,9 +5758,7 @@ package body Sem_Ch3 is and then Expander_Active then declare - Full_Der : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Full_Der : constant Entity_Id := Make_Temporary (Loc, 'T'); New_Ext : constant Node_Id := Copy_Separate_Tree (Record_Extension_Part (Type_Definition (N))); @@ -6778,6 +6808,15 @@ package body Sem_Ch3 is Mark_Rewrite_Insertion (New_Decl); Insert_Before (N, New_Decl); + -- In the extension case, make sure ancestor is frozen appropriately + -- (see also non-discriminated case below). + + if Present (Record_Extension_Part (Type_Def)) + or else Is_Interface (Parent_Base) + then + Freeze_Before (New_Decl, Parent_Type); + end if; + -- Note that this call passes False for the Derive_Subps parameter -- because subprogram derivation is deferred until after creating -- the subtype (see below). @@ -6868,9 +6907,7 @@ package body Sem_Ch3 is -- The declaration of a specific descendant of an interface type -- freezes the interface type (RM 13.14). - if not Private_Extension - or else Is_Interface (Parent_Base) - then + if not Private_Extension or else Is_Interface (Parent_Base) then Freeze_Before (N, Parent_Type); end if; @@ -6954,9 +6991,8 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251) - if Ada_Version = Ada_05 - and then Is_Tagged - then + if Ada_Version >= Ada_05 and then Is_Tagged then + -- "The declaration of a specific descendant of an interface type -- freezes the interface type" (RM 13.14). @@ -7548,9 +7584,7 @@ package body Sem_Ch3 is begin D := First_Entity (Derived_Type); while Present (D) loop - if Ekind (D) = E_Discriminant - or else Ekind (D) = E_Component - then + if Ekind_In (D, E_Discriminant, E_Component) then if Is_Itype (Etype (D)) and then Ekind (Etype (D)) = E_Anonymous_Access_Type then @@ -7725,6 +7759,7 @@ package body Sem_Ch3 is Set_Ekind (D_Minal, E_In_Parameter); Set_Mechanism (D_Minal, Default_Mechanism); Set_Etype (D_Minal, Etype (Discrim)); + Set_Scope (D_Minal, Current_Scope); Set_Discriminal (Discrim, D_Minal); Set_Discriminal_Link (D_Minal, Discrim); @@ -7741,6 +7776,7 @@ package body Sem_Ch3 is Set_Ekind (CR_Disc, E_In_Parameter); Set_Mechanism (CR_Disc, Default_Mechanism); Set_Etype (CR_Disc, Etype (Discrim)); + Set_Scope (CR_Disc, Current_Scope); Set_Discriminal_Link (CR_Disc, Discrim); Set_CR_Discriminant (Discrim, CR_Disc); end if; @@ -8587,8 +8623,7 @@ package body Sem_Ch3 is -- them all, and not just the first one). Error_Msg_Node_2 := Subp; - Error_Msg_N - ("nonabstract type& has abstract subprogram&!", T); + Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); end if; end if; @@ -8741,9 +8776,7 @@ package body Sem_Ch3 is begin if not Comes_From_Source (E) then - if Ekind (E) = E_Task_Type - or else Ekind (E) = E_Protected_Type - then + if Ekind_In (E, E_Task_Type, E_Protected_Type) then -- It may be an anonymous protected type created for a -- single variable. Post error on variable, if present. @@ -8791,8 +8824,7 @@ package body Sem_Ch3 is Error_Msg_NE ("missing full declaration for }", Parent (E), E); else - Error_Msg_NE - ("missing body for &", Parent (E), E); + Error_Msg_NE ("missing body for &", Parent (E), E); end if; -- Package body has no completion for a declaration that appears @@ -8803,8 +8835,7 @@ package body Sem_Ch3 is Error_Msg_Sloc := Sloc (E); if Is_Type (E) then - Error_Msg_NE - ("missing full declaration for }!", Body_Id, E); + Error_Msg_NE ("missing full declaration for }!", Body_Id, E); elsif Is_Overloadable (E) and then Current_Entity_In_Scope (E) /= E @@ -9584,7 +9615,14 @@ package body Sem_Ch3 is if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); Set_Primitive_Operations (Full, Primitive_Operations (Full_Base)); - Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + + -- Inherit class_wide type of full_base in case the partial view was + -- not tagged. Otherwise it has already been created when the private + -- subtype was analyzed. + + if No (Class_Wide_Type (Full)) then + Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base)); + end if; -- If this is a subtype of a protected or task type, constrain its -- corresponding record, unless this is a subtype without constraints, @@ -9654,14 +9692,11 @@ package body Sem_Ch3 is then declare Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); - Decl : constant Node_Id := + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'S'); + Decl : constant Node_Id := Make_Subtype_Declaration (Loc, - Defining_Identifier => - Def_Id, - Subtype_Indication => + Defining_Identifier => Def_Id, + Subtype_Indication => Relocate_Node (Curr_Obj_Def)); begin @@ -9823,13 +9858,15 @@ package body Sem_Ch3 is and then not In_Private_Part (Current_Scope) then Error_Msg_Sloc := Sloc (Prev); - Error_Msg_N ("full constant for declaration#" - & " must be in private part", N); + Error_Msg_N + ("full constant for declaration#" + & " must be in private part", N); elsif Ekind (Current_Scope) = E_Package - and then List_Containing (Parent (Prev)) - /= Visible_Declarations - (Specification (Unit_Declaration_Node (Current_Scope))) + and then + List_Containing (Parent (Prev)) /= + Visible_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) then Error_Msg_N ("deferred constant must be declared in visible part", @@ -10076,8 +10113,7 @@ package body Sem_Ch3 is -- is such an array type... (RM 3.6.1) if Is_Constrained (T) then - Error_Msg_N - ("array type is already constrained", Subtype_Mark (SI)); + Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); Constraint_OK := False; else @@ -10825,8 +10861,7 @@ package body Sem_Ch3 is Error_Msg_N ("(Ada 2005) incomplete subtype may not be constrained", C); else - Error_Msg_N - ("invalid constraint: type has no discriminant", C); + Error_Msg_N ("invalid constraint: type has no discriminant", C); end if; Fixup_Bad_Constraint; @@ -11064,6 +11099,7 @@ package body Sem_Ch3 is else Set_Ekind (Def_Id, E_Enumeration_Subtype); Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_First_Literal (Def_Id, First_Literal (T)); end if; Set_Size_Info (Def_Id, (T)); @@ -11949,7 +11985,7 @@ package body Sem_Ch3 is -- non-abstract tagged types that can reference abstract primitives -- through its Alias attribute are the internal entities that have -- attribute Interface_Alias, and these entities are generated later - -- by Freeze_Record_Type). + -- by Add_Internal_Interface_Entities). if In_Private_Part (Current_Scope) and then Is_Abstract_Type (Parent_Type) @@ -12728,6 +12764,12 @@ package body Sem_Ch3 is -- corresponding operations of the actual. else + pragma Assert (No (Node (Act_Elmt)) + or else (Primitive_Names_Match (Subp, Node (Act_Elmt)) + and then + Type_Conformant (Subp, Node (Act_Elmt), + Skip_Controlling_Formals => True))); + Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); @@ -12812,13 +12854,13 @@ package body Sem_Ch3 is Subp := Node (Elmt); Alias_Subp := Ultimate_Alias (Subp); - -- At this early stage Derived_Type has no entities with attribute - -- Interface_Alias. In addition, such primitives are always - -- located at the end of the list of primitives of Parent_Type. - -- Therefore, if found we can safely stop processing pending - -- entities. + -- Do not derive internal entities of the parent that link + -- interface primitives and its covering primitive. These + -- entities will be added to this type when frozen. - exit when Present (Interface_Alias (Subp)); + if Present (Interface_Alias (Subp)) then + goto Continue; + end if; -- If the generic actual is present find the corresponding -- operation in the generic actual. If the parent type is a @@ -12833,7 +12875,11 @@ package body Sem_Ch3 is or else (Present (Generic_Actual) and then Present (Act_Subp) - and then not Primitive_Names_Match (Subp, Act_Subp)) + and then not + (Primitive_Names_Match (Subp, Act_Subp) + and then + Type_Conformant (Subp, Act_Subp, + Skip_Controlling_Formals => True))) then pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); @@ -12843,14 +12889,73 @@ package body Sem_Ch3 is -- Handle entities associated with interface primitives - if Present (Alias (Subp)) - and then Is_Interface (Find_Dispatching_Type (Alias (Subp))) + if Present (Alias_Subp) + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) and then not Is_Predefined_Dispatching_Operation (Subp) then + -- Search for the primitive in the homonym chain + Act_Subp := Find_Primitive_Covering_Interface (Tagged_Type => Generic_Actual, - Iface_Prim => Subp); + Iface_Prim => Alias_Subp); + + -- Previous search may not locate primitives covering + -- interfaces defined in generics units or instantiations. + -- (it fails if the covering primitive has formals whose + -- type is also defined in generics or instantiations). + -- In such case we search in the list of primitives of the + -- generic actual for the internal entity that links the + -- interface primitive and the covering primitive. + + if No (Act_Subp) + and then Is_Generic_Type (Parent_Type) + then + -- This code has been designed to handle only generic + -- formals that implement interfaces that are defined + -- in a generic unit or instantiation. If this code is + -- needed for other cases we must review it because + -- (given that it relies on Original_Location to locate + -- the primitive of Generic_Actual that covers the + -- interface) it could leave linked through attribute + -- Alias entities of unrelated instantiations). + + pragma Assert + (Is_Generic_Unit + (Scope (Find_Dispatching_Type (Alias_Subp))) + or else + Instantiation_Depth + (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); + + declare + Iface_Prim_Loc : constant Source_Ptr := + Original_Location (Sloc (Alias_Subp)); + Elmt : Elmt_Id; + Prim : Entity_Id; + begin + Elmt := + First_Elmt (Primitive_Operations (Generic_Actual)); + + Search : while Present (Elmt) loop + Prim := Node (Elmt); + + if Present (Interface_Alias (Prim)) + and then Original_Location + (Sloc (Interface_Alias (Prim))) + = Iface_Prim_Loc + then + Act_Subp := Alias (Prim); + exit Search; + end if; + + Next_Elmt (Elmt); + end loop Search; + end; + end if; + + pragma Assert (Present (Act_Subp) + or else Is_Abstract_Type (Generic_Actual) + or else Serious_Errors_Detected > 0); -- Handle predefined primitives plus the rest of user-defined -- primitives @@ -12868,6 +12973,10 @@ package body Sem_Ch3 is Next_Elmt (Act_Elmt); end loop; + + if No (Act_Elmt) then + Act_Subp := Empty; + end if; end if; end if; @@ -12926,6 +13035,7 @@ package body Sem_Ch3 is Act_Subp := Node (Act_Elmt); end if; + <<Continue>> Next_Elmt (Elmt); end loop; @@ -13355,9 +13465,7 @@ package body Sem_Ch3 is -- Check for early use of incomplete or private type - if Ekind (Parent_Type) = E_Void - or else Ekind (Parent_Type) = E_Incomplete_Type - then + if Ekind_In (Parent_Type, E_Void, E_Incomplete_Type) then Error_Msg_N ("premature derivation of incomplete type", Indic); return; @@ -13501,8 +13609,9 @@ package body Sem_Ch3 is (not Is_Interface (Parent_Type) or else not Is_Limited_Interface (Parent_Type)) then - Error_Msg_NE ("parent type& of limited type must be limited", - N, Parent_Type); + Error_Msg_NE + ("parent type& of limited type must be limited", + N, Parent_Type); end if; end if; end Derived_Type_Declaration; @@ -13955,9 +14064,9 @@ package body Sem_Ch3 is elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then if No (Record_Extension_Part (Type_Definition (N))) then - Error_Msg_NE ( - "full declaration of } must be a record extension", - Prev, Id); + Error_Msg_NE + ("full declaration of } must be a record extension", + Prev, Id); -- Set some attributes to produce a usable full view @@ -14778,8 +14887,8 @@ package body Sem_Ch3 is then null; - elsif Ekind (Derived_Base) = E_Private_Type - or else Ekind (Derived_Base) = E_Limited_Private_Type + elsif Ekind_In (Derived_Base, E_Private_Type, + E_Limited_Private_Type) then null; @@ -14947,9 +15056,7 @@ package body Sem_Ch3 is -- Start of processing for Is_Visible_Component begin - if Ekind (C) = E_Component - or else Ekind (C) = E_Discriminant - then + if Ekind_In (C, E_Component, E_Discriminant) then Original_Comp := Original_Record_Component (C); end if; @@ -16267,15 +16374,17 @@ package body Sem_Ch3 is Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by full type " & - "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by partial view " & - "(RM-2005 7.3 (7.3/2))", Full_T, Iface); + Error_Msg_NE + ("interface & not implemented by partial view " & + "(RM-2005 7.3 (7.3/2))", Full_T, Iface); end if; end; end if; @@ -16484,9 +16593,9 @@ package body Sem_Ch3 is while Present (Priv_Elmt) loop Priv := Node (Priv_Elmt); - if Ekind (Priv) = E_Private_Subtype - or else Ekind (Priv) = E_Limited_Private_Subtype - or else Ekind (Priv) = E_Record_Subtype_With_Private + if Ekind_In (Priv, E_Private_Subtype, + E_Limited_Private_Subtype, + E_Record_Subtype_With_Private) then Full := Make_Defining_Identifier (Sloc (Priv), Chars (Priv)); Set_Is_Itype (Full); @@ -16634,10 +16743,7 @@ package body Sem_Ch3 is Prim := Next_Entity (Full_T); while Present (Prim) and then Prim /= Priv_T loop - if Ekind (Prim) = E_Procedure - or else - Ekind (Prim) = E_Function - then + if Ekind_In (Prim, E_Procedure, E_Function) then Disp_Typ := Find_Dispatching_Type (Prim); if Disp_Typ = Full_T @@ -16667,10 +16773,9 @@ package body Sem_Ch3 is end loop; end if; - -- For the tagged case, the two views can share the same - -- Primitive Operation list and the same class wide type. - -- Update attributes of the class-wide type which depend on - -- the full declaration. + -- For the tagged case, the two views can share the same primitive + -- operations list and the same class-wide type. Update attributes + -- of the class-wide type which depend on the full declaration. if Is_Tagged_Type (Priv_T) then Set_Primitive_Operations (Priv_T, Full_List); @@ -17501,19 +17606,27 @@ package body Sem_Ch3 is and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type and then Full_View (Current_Entity (Typ)) = Typ then + if Is_Tagged + and then Comes_From_Source (Current_Entity (Typ)) + and then not Is_Tagged_Type (Current_Entity (Typ)) + then + Make_Class_Wide_Type (Typ); + Error_Msg_N + ("incomplete view of tagged type should be declared tagged?", + Parent (Current_Entity (Typ))); + end if; return; else Inc_T := Make_Defining_Identifier (Loc, Chars (Typ)); Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T); - -- Type has already been inserted into the current scope. - -- Remove it, and add incomplete declaration for type, so - -- that subsequent anonymous access types can use it. - -- The entity is unchained from the homonym list and from - -- immediate visibility. After analysis, the entity in the - -- incomplete declaration becomes immediately visible in the - -- record declaration that follows. + -- Type has already been inserted into the current scope. Remove + -- it, and add incomplete declaration for type, so that subsequent + -- anonymous access types can use it. The entity is unchained from + -- the homonym list and from immediate visibility. After analysis, + -- the entity in the incomplete declaration becomes immediately + -- visible in the record declaration that follows. H := Current_Entity (Typ); @@ -17534,8 +17647,9 @@ package body Sem_Ch3 is Set_Full_View (Inc_T, Typ); if Is_Tagged then - -- Create a common class-wide type for both views, and set - -- the Etype of the class-wide type to the full view. + + -- Create a common class-wide type for both views, and set the + -- Etype of the class-wide type to the full view. Make_Class_Wide_Type (Inc_T); Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T)); @@ -17697,9 +17811,7 @@ package body Sem_Ch3 is (Access_Definition (Comp_Def)); Build_Incomplete_Type_Declaration; - Anon_Access := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Anon_Access := Make_Temporary (Loc, 'S'); -- Create a declaration for the anonymous access type: either -- an access_to_object or an access_to_subprogram. diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 6bfa52844d0..18b585f04aa 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -84,13 +84,11 @@ package Sem_Ch3 is procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Process an access type declaration - procedure Build_Itype_Reference - (Ityp : Entity_Id; - Nod : Node_Id); + procedure Build_Itype_Reference (Ityp : Entity_Id; Nod : Node_Id); -- Create a reference to an internal type, for use by Gigi. The back-end - -- elaborates itypes on demand, i.e. when their first use is seen. This - -- can lead to scope anomalies if the first use is within a scope that is - -- nested within the scope that contains the point of definition of the + -- elaborates itypes on demand, i.e. when their first use is seen. This can + -- lead to scope anomalies if the first use is within a scope that is + -- nested within the scope that contains the point of definition of the -- itype. The Itype_Reference node forces the elaboration of the itype -- in the proper scope. The node is inserted after Nod, which is the -- enclosing declaration that generated Ityp. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 126b003d148..743d128e65d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,17 +43,18 @@ with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; -with Sem_SCIL; use Sem_SCIL; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; @@ -305,8 +306,7 @@ package body Sem_Ch4 is end if; if Opnd = Left_Opnd (N) then - Error_Msg_N - ("\left operand has the following interpretations", N); + Error_Msg_N ("\left operand has the following interpretations", N); else Error_Msg_N ("\right operand has the following interpretations", N); @@ -472,8 +472,7 @@ package body Sem_Ch4 is end if; if Expander_Active then - Def_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Def_Id := Make_Temporary (Loc, 'S'); Insert_Action (E, Make_Subtype_Declaration (Loc, @@ -818,10 +817,10 @@ package body Sem_Ch4 is elsif Nkind (Nam) = N_Selected_Component then Nam_Ent := Entity (Selector_Name (Nam)); - if Ekind (Nam_Ent) /= E_Entry - and then Ekind (Nam_Ent) /= E_Entry_Family - and then Ekind (Nam_Ent) /= E_Function - and then Ekind (Nam_Ent) /= E_Procedure + if not Ekind_In (Nam_Ent, E_Entry, + E_Entry_Family, + E_Function, + E_Procedure) then Error_Msg_N ("name in call is not a callable entity", Nam); Set_Etype (N, Any_Type); @@ -1049,6 +1048,141 @@ package body Sem_Ch4 is end if; end Analyze_Call; + ----------------------------- + -- Analyze_Case_Expression -- + ----------------------------- + + procedure Analyze_Case_Expression (N : Node_Id) is + Expr : constant Node_Id := Expression (N); + FirstX : constant Node_Id := Expression (First (Alternatives (N))); + Alt : Node_Id; + Exp_Type : Entity_Id; + Exp_Btype : Entity_Id; + + Last_Choice : Nat; + Dont_Care : Boolean; + Others_Present : Boolean; + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the case expression has a non static choice. + + package Case_Choices_Processing is new + Generic_Choices_Processing + (Get_Alternatives => Alternatives, + Get_Choices => Discrete_Choices, + Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => No_OP); + use Case_Choices_Processing; + + Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in case expression is not static!", Choice); + end Non_Static_Choice_Error; + + -- Start of processing for Analyze_Case_Expression + + begin + if Comes_From_Source (N) then + Check_Compiler_Unit (N); + end if; + + Analyze_And_Resolve (Expr, Any_Discrete); + Check_Unset_Reference (Expr); + Exp_Type := Etype (Expr); + Exp_Btype := Base_Type (Exp_Type); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Analyze (Expression (Alt)); + Next (Alt); + end loop; + + if not Is_Overloaded (FirstX) then + Set_Etype (N, Etype (FirstX)); + + else + declare + I : Interp_Index; + It : Interp; + + begin + Set_Etype (N, Any_Type); + + Get_First_Interp (FirstX, I, It); + while Present (It.Nam) loop + + -- For each intepretation of the first expression, we only + -- add the intepretation if every other expression in the + -- case expression alternatives has a compatible type. + + Alt := Next (First (Alternatives (N))); + while Present (Alt) loop + exit when not Has_Compatible_Type (Expression (Alt), It.Typ); + Next (Alt); + end loop; + + if No (Alt) then + Add_One_Interp (N, It.Typ, It.Typ); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + Exp_Btype := Base_Type (Exp_Type); + + -- The expression must be of a discrete type which must be determinable + -- independently of the context in which the expression occurs, but + -- using the fact that the expression must be of a discrete type. + -- Moreover, the type this expression must not be a character literal + -- (which is always ambiguous). + + -- If error already reported by Resolve, nothing more to do + + if Exp_Btype = Any_Discrete + or else Exp_Btype = Any_Type + then + return; + + elsif Exp_Btype = Any_Character then + Error_Msg_N + ("character literal as case expression is ambiguous", Expr); + return; + end if; + + -- 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 + -- use base type when the case expression is parenthesized. + + if Paren_Count (Expr) > 0 + or else (Is_Entity_Name (Expr) + and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter) + then + Exp_Type := Exp_Btype; + end if; + + -- Call instantiated Analyze_Choices which does the rest of the work + + Analyze_Choices + (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); + + if Exp_Type = Universal_Integer and then not Others_Present then + Error_Msg_N + ("case on universal integer requires OTHERS choice", Expr); + end if; + end Analyze_Case_Expression; + --------------------------- -- Analyze_Comparison_Op -- --------------------------- @@ -1174,7 +1308,6 @@ package body Sem_Ch4 is if Present (Op_Id) then if Ekind (Op_Id) = E_Operator then - LT := Base_Type (Etype (L)); RT := Base_Type (Etype (R)); @@ -1251,9 +1384,17 @@ package body Sem_Ch4 is procedure Analyze_Conditional_Expression (N : Node_Id) is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); + Else_Expr : Node_Id; begin + -- Defend against error of missing expressions from previous error + + if No (Then_Expr) then + return; + end if; + + Else_Expr := Next (Then_Expr); + if Comes_From_Source (N) then Check_Compiler_Unit (N); end if; @@ -1265,8 +1406,13 @@ package body Sem_Ch4 is Analyze_Expression (Else_Expr); end if; + -- If then expression not overloaded, then that decides the type + if not Is_Overloaded (Then_Expr) then Set_Etype (N, Etype (Then_Expr)); + + -- Case where then expression is overloaded + else declare I : Interp_Index; @@ -1276,6 +1422,12 @@ package body Sem_Ch4 is Set_Etype (N, Any_Type); Get_First_Interp (Then_Expr, I, It); while Present (It.Nam) loop + + -- For each possible intepretation of the Then Expression, + -- add it only if the else expression has a compatible type. + + -- Is this right if Else_Expr is empty? + if Has_Compatible_Type (Else_Expr, It.Typ) then Add_One_Interp (N, It.Typ, It.Typ); end if; @@ -1591,6 +1743,25 @@ package body Sem_Ch4 is Check_Parameterless_Call (N); end Analyze_Expression; + ------------------------------------- + -- Analyze_Expression_With_Actions -- + ------------------------------------- + + procedure Analyze_Expression_With_Actions (N : Node_Id) is + A : Node_Id; + + begin + A := First (Actions (N)); + loop + Analyze (A); + Next (A); + exit when No (A); + end loop; + + Analyze_Expression (Expression (N)); + Set_Etype (N, Etype (Expression (N))); + end Analyze_Expression_With_Actions; + ------------------------------------ -- Analyze_Indexed_Component_Form -- ------------------------------------ @@ -1944,7 +2115,8 @@ package body Sem_Ch4 is elsif Ekind (Etype (P)) = E_Subprogram_Type or else (Is_Access_Type (Etype (P)) and then - Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type) + Ekind (Designated_Type (Etype (P))) = + E_Subprogram_Type) then -- Call to access_to-subprogram with possible implicit dereference @@ -1969,7 +2141,7 @@ package body Sem_Ch4 is if Ekind (P_T) = E_Subprogram_Type or else (Is_Access_Type (P_T) and then - Ekind (Designated_Type (P_T)) = E_Subprogram_Type) + Ekind (Designated_Type (P_T)) = E_Subprogram_Type) then Process_Function_Call; @@ -2172,7 +2344,7 @@ package body Sem_Ch4 is Analyze_Expression (L); if No (R) - and then Extensions_Allowed + and then Ada_Version >= Ada_12 then Analyze_Set_Membership; return; @@ -3106,8 +3278,8 @@ package body Sem_Ch4 is -- Analyze_Selected_Component -- -------------------------------- - -- Prefix is a record type or a task or protected type. In the - -- later case, the selector must denote a visible entry. + -- Prefix is a record type or a task or protected type. In the latter case, + -- the selector must denote a visible entry. procedure Analyze_Selected_Component (N : Node_Id) is Name : constant Node_Id := Prefix (N); @@ -3125,6 +3297,9 @@ package body Sem_Ch4 is -- a class-wide type, we use its root type, whose components are -- present in the class-wide type. + Is_Single_Concurrent_Object : Boolean; + -- Set True if the prefix is a single task or a single protected object + function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean; -- It is known that the parent of N denotes a subprogram call. Comp -- is an overloadable component of the concurrent type of the prefix. @@ -3295,6 +3470,15 @@ package body Sem_Ch4 is Type_To_Use := Root_Type (Prefix_Type); end if; + -- If the prefix is a single concurrent object, use its name in error + -- messages, rather than that of its anonymous type. + + Is_Single_Concurrent_Object := + Is_Concurrent_Type (Prefix_Type) + and then Is_Internal_Name (Chars (Prefix_Type)) + and then not Is_Derived_Type (Prefix_Type) + and then Is_Entity_Name (Name); + Comp := First_Entity (Type_To_Use); -- If the selector has an original discriminant, the node appears in @@ -3533,9 +3717,8 @@ package body Sem_Ch4 is return; else - Error_Msg_NE - ("invisible selector for }", - N, First_Subtype (Prefix_Type)); + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("invisible selector& for }", N, Sel); Set_Entity (Sel, Any_Id); Set_Etype (N, Any_Type); end if; @@ -3580,10 +3763,13 @@ package body Sem_Ch4 is Has_Candidate := True; end if; - elsif Ekind (Comp) = E_Discriminant - or else Ekind (Comp) = E_Entry_Family + -- Note: a selected component may not denote a component of a + -- protected type (4.1.3(7)). + + elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family) or else (In_Scope - and then Is_Entity_Name (Name)) + and then not Is_Protected_Type (Prefix_Type) + and then Is_Entity_Name (Name)) then Set_Entity_With_Style_Check (Sel, Comp); Generate_Reference (Comp, Sel); @@ -3647,6 +3833,28 @@ package body Sem_Ch4 is end if; end if; + if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then + -- Case of a prefix of a protected type: selector might denote + -- an invisible private component. + + Comp := First_Private_Entity (Base_Type (Prefix_Type)); + while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop + Next_Entity (Comp); + end loop; + + if Present (Comp) then + if Is_Single_Concurrent_Object then + Error_Msg_Node_2 := Entity (Name); + Error_Msg_NE ("invisible selector& for &", N, Sel); + + else + Error_Msg_Node_2 := First_Subtype (Prefix_Type); + Error_Msg_NE ("invisible selector& for }", N, Sel); + end if; + return; + end if; + end if; + Set_Is_Overloaded (N, Is_Overloaded (Sel)); else @@ -3659,15 +3867,7 @@ package body Sem_Ch4 is if Etype (N) = Any_Type then - -- If the prefix is a single concurrent object, use its name in the - -- error message, rather than that of its anonymous type. - - if Is_Concurrent_Type (Prefix_Type) - and then Is_Internal_Name (Chars (Prefix_Type)) - and then not Is_Derived_Type (Prefix_Type) - and then Is_Entity_Name (Name) - then - + if Is_Single_Concurrent_Object then Error_Msg_Node_2 := Entity (Name); Error_Msg_NE ("no selector& for&", N, Sel); @@ -3904,15 +4104,6 @@ package body Sem_Ch4 is T : Entity_Id; begin - -- Check if the expression is a function call for which we need to - -- adjust a SCIL dispatching node. - - if Generate_SCIL - and then Nkind (Expr) = N_Function_Call - then - Adjust_SCIL_Node (N, Expr); - end if; - -- If Conversion_OK is set, then the Etype is already set, and the -- only processing required is to analyze the expression. This is -- used to construct certain "illegal" conversions which are not @@ -4502,9 +4693,7 @@ 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 (It.Nam) = E_Function - or else Ekind (It.Nam) = E_Operator - then + if Ekind_In (It.Nam, E_Function, E_Operator) then return; else Get_Next_Interp (X, It); @@ -5316,10 +5505,11 @@ package body Sem_Ch4 is end if; end if; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("operator for} is not directly visible!", N, First_Subtype (Candidate_Type)); - Error_Msg_N ("use clause would make operation legal!", N); + Error_Msg_N -- CODEFIX + ("use clause would make operation legal!", N); return; -- If either operand is a junk operand (e.g. package name), then @@ -6675,29 +6865,31 @@ package body Sem_Ch4 is if Is_Derived_Type (T) then return Primitive_Operations (T); - elsif Ekind (Scope (T)) = E_Procedure - or else Ekind (Scope (T)) = E_Function - then + elsif Ekind_In (Scope (T), E_Procedure, E_Function) then + -- Scan the list of generic formals to find subprograms -- that may have a first controlling formal of the type. - declare - Decl : Node_Id; - - begin - Decl := - First (Generic_Formal_Declarations - (Unit_Declaration_Node (Scope (T)))); - while Present (Decl) loop - if Nkind (Decl) in N_Formal_Subprogram_Declaration then - Subp := Defining_Entity (Decl); - Check_Candidate; - end if; - - Next (Decl); - end loop; - end; + if Nkind (Unit_Declaration_Node (Scope (T))) + = N_Generic_Subprogram_Declaration + then + declare + Decl : Node_Id; + + begin + Decl := + First (Generic_Formal_Declarations + (Unit_Declaration_Node (Scope (T)))); + while Present (Decl) loop + if Nkind (Decl) in N_Formal_Subprogram_Declaration then + Subp := Defining_Entity (Decl); + Check_Candidate; + end if; + Next (Decl); + end loop; + end; + end if; return Candidates; else @@ -6707,7 +6899,15 @@ package body Sem_Ch4 is -- declaration or body (either the one that declares T, or a -- child unit). - Subp := First_Entity (Scope (T)); + -- For a subtype representing a generic actual type, go to the + -- base type. + + if Is_Generic_Actual_Type (T) then + Subp := First_Entity (Scope (Base_Type (T))); + else + Subp := First_Entity (Scope (T)); + end if; + while Present (Subp) loop if Is_Overloadable (Subp) then Check_Candidate; @@ -6780,13 +6980,14 @@ package body Sem_Ch4 is -- corresponding record (base) type. if Is_Concurrent_Type (Obj_Type) then - if not Present (Corresponding_Record_Type (Obj_Type)) then - return False; + if Present (Corresponding_Record_Type (Obj_Type)) then + Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); + Elmt := First_Elmt (Primitive_Operations (Corr_Type)); + else + Corr_Type := Obj_Type; + Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type)); end if; - Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type)); - Elmt := First_Elmt (Primitive_Operations (Corr_Type)); - elsif not Is_Generic_Type (Obj_Type) then Corr_Type := Obj_Type; Elmt := First_Elmt (Primitive_Operations (Obj_Type)); diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index 6c8d1a33b55..e5c646f9bb8 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -30,11 +30,13 @@ package Sem_Ch4 is procedure Analyze_Allocator (N : Node_Id); procedure Analyze_Arithmetic_Op (N : Node_Id); procedure Analyze_Call (N : Node_Id); + procedure Analyze_Case_Expression (N : Node_Id); procedure Analyze_Comparison_Op (N : Node_Id); procedure Analyze_Concatenation (N : Node_Id); procedure Analyze_Conditional_Expression (N : Node_Id); procedure Analyze_Equality_Op (N : Node_Id); procedure Analyze_Explicit_Dereference (N : Node_Id); + procedure Analyze_Expression_With_Actions (N : Node_Id); procedure Analyze_Logical_Op (N : Node_Id); procedure Analyze_Membership_Op (N : Node_Id); procedure Analyze_Negation (N : Node_Id); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 44909e2e36b..816e12b979e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,6 @@ with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; @@ -448,14 +447,14 @@ package body Sem_Ch5 is end if; return; - -- Enforce RM 3.9.3 (8): left-hand side cannot be abstract + -- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be + -- abstract. This is only checked when the assignment Comes_From_Source, + -- because in some cases the expander generates such assignments (such + -- in the _assign operation for an abstract type). - elsif Is_Interface (T1) - and then not Is_Class_Wide_Type (T1) - then + elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then Error_Msg_N - ("target of assignment operation may not be abstract", Lhs); - return; + ("target of assignment operation must not be abstract", Lhs); end if; -- Resolution may have updated the subtype, in case the left-hand @@ -693,10 +692,10 @@ package body Sem_Ch5 is and then Nkind (Original_Node (Rhs)) not in N_Op then if Nkind (Lhs) in N_Has_Entity then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?useless assignment of & to itself!", N, Entity (Lhs)); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("?useless assignment of object to itself!", N); end if; end if; @@ -948,7 +947,7 @@ package body Sem_Ch5 is -- the case statement has a non static choice. procedure Process_Statements (Alternative : Node_Id); - -- Analyzes all the statements associated to a case alternative. + -- Analyzes all the statements associated with a case alternative. -- Needed by the generic instantiation below. package Case_Choices_Processing is new @@ -998,11 +997,9 @@ package body Sem_Ch5 is if Is_Entity_Name (Exp) then Ent := Entity (Exp); - if Ekind (Ent) = E_Variable - or else - Ekind (Ent) = E_In_Out_Parameter - or else - Ekind (Ent) = E_Out_Parameter + if Ekind_In (Ent, E_Variable, + E_In_Out_Parameter, + E_Out_Parameter) then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr @@ -1198,7 +1195,7 @@ package body Sem_Ch5 is else Error_Msg_N ("cannot exit from program unit or accept statement", N); - exit; + return; end if; end loop; @@ -1477,8 +1474,8 @@ package body Sem_Ch5 is R_Copy : constant Node_Id := New_Copy_Tree (R); Lo : constant Node_Id := Low_Bound (R); Hi : constant Node_Id := High_Bound (R); - New_Lo_Bound : Node_Id := Empty; - New_Hi_Bound : Node_Id := Empty; + New_Lo_Bound : Node_Id; + New_Hi_Bound : Node_Id; Typ : Entity_Id; Save_Analysis : Boolean; @@ -1522,9 +1519,7 @@ package body Sem_Ch5 is Analyze_And_Resolve (Original_Bound, Typ); - Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Id := Make_Temporary (Loc, 'S', Original_Bound); -- Normally, the best approach is simply to generate a constant -- declaration that captures the bound. However, there is a nasty @@ -1576,15 +1571,6 @@ package body Sem_Ch5 is Name => New_Occurrence_Of (Id, Loc), Expression => Relocate_Node (Original_Bound)); - -- If the relocated node is a function call then check if some - -- SCIL node references it and needs readjustment. - - if Generate_SCIL - and then Nkind (Original_Bound) = N_Function_Call - then - Adjust_SCIL_Node (Original_Bound, Expression (Assign)); - end if; - Insert_Before (Parent (N), Assign); Analyze (Assign); @@ -1723,13 +1709,10 @@ package body Sem_Ch5 is then declare Loc : constant Source_Ptr := Sloc (N); - Arr : constant Entity_Id := - Etype (Entity (Prefix (DS))); + Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); Indx : constant Entity_Id := Base_Type (Etype (First_Index (Arr))); - Subt : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); + Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); Decl : Node_Id; begin diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index befa1d48e97..cbdaf68180f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -98,7 +98,7 @@ package body Sem_Ch6 is ----------------------- procedure Analyze_Return_Statement (N : Node_Id); - -- Common processing for simple_ and extended_return_statements + -- Common processing for simple and extended return statements procedure Analyze_Function_Return (N : Node_Id); -- Subsidiary to Analyze_Return_Statement. Called when the return statement @@ -106,11 +106,12 @@ package body Sem_Ch6 is procedure Analyze_Return_Type (N : Node_Id); -- Subsidiary to Process_Formals: analyze subtype mark in function - -- specification, in a context where the formals are visible and hide + -- specification in a context where the formals are visible and hide -- outer homographs. procedure Analyze_Subprogram_Body_Helper (N : Node_Id); - -- Does all the real work of Analyze_Subprogram_Body + -- Does all the real work of Analyze_Subprogram_Body. This is split out so + -- that we can use RETURN but not skip the debug output at the end. procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); -- Analyze a generic subprogram body. N is the body to be analyzed, and @@ -514,10 +515,10 @@ package body Sem_Ch6 is ------------------------------------- procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is - Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); - R_Stm_Type : constant Entity_Id := Etype (Return_Obj); - -- Subtype given in the extended return statement; - -- this must match R_Type. + Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); + + R_Stm_Type : constant Entity_Id := Etype (Return_Obj); + -- Subtype given in the extended return statement (must match R_Type) Subtype_Ind : constant Node_Id := Object_Definition (Original_Node (Obj_Decl)); @@ -542,7 +543,7 @@ package body Sem_Ch6 is -- True if type of the return object is an anonymous access type begin - -- First, avoid cascade errors: + -- First, avoid cascaded errors if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then return; @@ -773,6 +774,11 @@ package body Sem_Ch6 is & "null-excluding return?", Reason => CE_Null_Not_Allowed); end if; + + -- Apply checks suggested by AI05-0144 (dangerous order dependence) + -- (Disabled for now) + + -- Check_Order_Dependence; end if; end Analyze_Function_Return; @@ -978,6 +984,7 @@ package body Sem_Ch6 is if Style_Check then Style.Check_Identifier (Body_Id, Gen_Id); end if; + End_Generic; end Analyze_Generic_Subprogram_Body; @@ -1037,6 +1044,7 @@ package body Sem_Ch6 is procedure Analyze_Call_And_Resolve; -- Do Analyze and Resolve calls for procedure call + -- At end, check illegal order dependence. ------------------------------ -- Analyze_Call_And_Resolve -- @@ -1047,6 +1055,11 @@ package body Sem_Ch6 is if Nkind (N) = N_Procedure_Call_Statement then Analyze_Call (N); Resolve (N, Standard_Void_Type); + + -- Apply checks suggested by AI05-0144 (Disabled for now) + + -- Check_Order_Dependence; + else Analyze (N); end if; @@ -1428,7 +1441,6 @@ package body Sem_Ch6 is Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); Conformant : Boolean; HSS : Node_Id; - Missing_Ret : Boolean; P_Ent : Entity_Id; Prot_Typ : Entity_Id := Empty; Spec_Id : Entity_Id; @@ -1470,6 +1482,10 @@ package body Sem_Ch6 is -- If pragma does not appear after the body, check whether there is -- an inline pragma before any local declarations. + procedure Check_Missing_Return; + -- Checks for a function with a no return statements, and also performs + -- the warning checks implemented by Check_Returns. + function Disambiguate_Spec return Entity_Id; -- When a primitive is declared between the private view and the full -- view of a concurrent type which implements an interface, a special @@ -1662,6 +1678,46 @@ package body Sem_Ch6 is end if; end Check_Inline_Pragma; + -------------------------- + -- Check_Missing_Return -- + -------------------------- + + procedure Check_Missing_Return is + Id : Entity_Id; + Missing_Ret : Boolean; + + begin + if Nkind (Body_Spec) = N_Function_Specification then + if Present (Spec_Id) then + Id := Spec_Id; + else + Id := Body_Id; + end if; + + if Return_Present (Id) then + Check_Returns (HSS, 'F', Missing_Ret); + + if Missing_Ret then + Set_Has_Missing_Return (Id); + end if; + + elsif (Is_Generic_Subprogram (Id) + or else not Is_Machine_Code_Subprogram (Id)) + and then not Body_Deleted + then + Error_Msg_N ("missing RETURN statement in function body", N); + end if; + + -- If procedure with No_Return, check returns + + elsif Nkind (Body_Spec) = N_Procedure_Specification + and then Present (Spec_Id) + and then No_Return (Spec_Id) + then + Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); + end if; + end Check_Missing_Return; + ----------------------- -- Disambiguate_Spec -- ----------------------- @@ -1850,9 +1906,10 @@ package body Sem_Ch6 is elsif not Is_Primitive (Spec_Id) and then Ekind (Scope (Spec_Id)) /= E_Protected_Type then - Error_Msg_N ("overriding indicator only allowed " & - "if subprogram is primitive", - Body_Spec); + Error_Msg_N + ("overriding indicator only allowed " & + "if subprogram is primitive", + Body_Spec); end if; elsif Style_Check -- ??? incorrect use of Style_Check! @@ -1885,6 +1942,12 @@ package body Sem_Ch6 is Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id)); Analyze_Generic_Subprogram_Body (N, Spec_Id); + + if Nkind (N) = N_Subprogram_Body then + HSS := Handled_Statement_Sequence (N); + Check_Missing_Return; + end if; + return; else @@ -2423,41 +2486,7 @@ package body Sem_Ch6 is end if; end if; - -- If function, check return statements - - if Nkind (Body_Spec) = N_Function_Specification then - declare - Id : Entity_Id; - - begin - if Present (Spec_Id) then - Id := Spec_Id; - else - Id := Body_Id; - end if; - - if Return_Present (Id) then - Check_Returns (HSS, 'F', Missing_Ret); - - if Missing_Ret then - Set_Has_Missing_Return (Id); - end if; - - elsif not Is_Machine_Code_Subprogram (Id) - and then not Body_Deleted - then - Error_Msg_N ("missing RETURN statement in function body", N); - end if; - end; - - -- If procedure with No_Return, check returns - - elsif Nkind (Body_Spec) = N_Procedure_Specification - and then Present (Spec_Id) - and then No_Return (Spec_Id) - then - Check_Returns (HSS, 'P', Missing_Ret, Spec_Id); - end if; + Check_Missing_Return; -- Now we are going to check for variables that are never modified in -- the body of the procedure. But first we deal with a special case @@ -2634,8 +2663,7 @@ package body Sem_Ch6 is end loop; if Is_Protected_Type (Current_Scope) then - Error_Msg_N - ("protected operation cannot be a null procedure", N); + Error_Msg_N ("protected operation cannot be a null procedure", N); end if; end if; @@ -3103,6 +3131,15 @@ package body Sem_Ch6 is and then Has_Excluded_Statement (Statements (S)) then return True; + + elsif Nkind (S) = N_Extended_Return_Statement then + if Has_Excluded_Statement + (Statements (Handled_Statement_Sequence (S))) + or else Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + then + return True; + end if; end if; Next (S); @@ -3125,6 +3162,7 @@ package body Sem_Ch6 is or else Is_Child_Unit (S) then return False; + elsif Ekind (S) = E_Package and then Has_Forward_Instantiation (S) then @@ -3169,12 +3207,33 @@ package body Sem_Ch6 is return Abandon; end if; + -- A return statement within an extended return is a noop + -- after inlining. + + elsif No (Expression (N)) + and then Nkind (Parent (Parent (N))) = + N_Extended_Return_Statement + then + return OK; + else -- Expression has wrong form return Abandon; end if; + -- We can only inline a build-in-place function if + -- it has a single extended return. + + elsif Nkind (N) = N_Extended_Return_Statement then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + else + return Abandon; + end if; + else return OK; end if; @@ -3185,11 +3244,18 @@ package body Sem_Ch6 is -- Start of processing for Has_Single_Return begin - return Check_All_Returns (N) = OK - and then Present (Declarations (N)) - and then Present (First (Declarations (N))) - and then Chars (Expression (Return_Statement)) = - Chars (Defining_Identifier (First (Declarations (N)))); + if Check_All_Returns (N) /= OK then + return False; + + elsif Nkind (Return_Statement) = N_Extended_Return_Statement then + return True; + + else + return Present (Declarations (N)) + and then Present (First (Declarations (N))) + and then Chars (Expression (Return_Statement)) = + Chars (Defining_Identifier (First (Declarations (N)))); + end if; end Has_Single_Return; -------------------- @@ -3478,21 +3544,21 @@ package body Sem_Ch6 is when Mode_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not mode conformant with operation inherited#!", Enode); else - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not mode conformant with declaration#!", Enode); end if; when Subtype_Conformant => if Nkind (Parent (Old_Id)) = N_Full_Type_Declaration then - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not subtype conformant with operation inherited#!", Enode); else - Error_Msg_N -- CODEFIX??? + Error_Msg_N ("not subtype conformant with declaration#!", Enode); end if; @@ -3976,22 +4042,25 @@ package body Sem_Ch6 is if not Is_Overriding_Operation (Op) then Error_Msg_N ("\\primitive % defined #", Typ); else - Error_Msg_N ("\\overriding operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\overriding operation % with " & + "convention % defined #", Typ); end if; else pragma Assert (Present (Alias (Op))); Error_Msg_Sloc := Sloc (Alias (Op)); - Error_Msg_N ("\\inherited operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\inherited operation % with " & + "convention % defined #", Typ); end if; Error_Msg_Name_1 := Chars (Op); Error_Msg_Name_2 := Get_Convention_Name (Convention (Iface_Prim)); Error_Msg_Sloc := Sloc (Iface_Prim); - Error_Msg_N ("\\overridden operation % with " & - "convention % defined #", Typ); + Error_Msg_N + ("\\overridden operation % with " & + "convention % defined #", Typ); -- Avoid cascading errors @@ -4409,7 +4478,8 @@ package body Sem_Ch6 is then Error_Msg_Node_2 := Alias (Overridden_Subp); Error_Msg_Sloc := Sloc (Error_Msg_Node_2); - Error_Msg_NE ("& does not match corresponding formal of&#", + Error_Msg_NE + ("& does not match corresponding formal of&#", Form1, Form1); exit; end if; @@ -4509,7 +4579,7 @@ package body Sem_Ch6 is elsif Must_Override (Spec) then if Is_Overriding_Operation (Subp) then - Set_Is_Overriding_Operation (Subp); + null; elsif not Can_Override then Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); @@ -5361,6 +5431,14 @@ package body Sem_Ch6 is -- and also returned as the result. These formals are always of mode IN. -- The new formal has the type Typ, is declared in Scope, and its name -- is given by a concatenation of the name of Assoc_Entity and Suffix. + -- The following suffixes are currently used. They should not be changed + -- without coordinating with CodePeer, which makes use of these to + -- provide better messages. + + -- O denotes the Constrained bit. + -- L denotes the accessibility level. + -- BIP_xxx denotes an extra formal for a build-in-place function. See + -- the full list in exp_ch6.BIP_Formal_Kind. ---------------------- -- Add_Extra_Formal -- @@ -5487,7 +5565,7 @@ package body Sem_Ch6 is and then not Is_Indefinite_Subtype (Formal_Type) then Set_Extra_Constrained - (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "F")); + (Formal, Add_Extra_Formal (Formal, Standard_Boolean, E, "O")); end if; end if; @@ -5520,7 +5598,7 @@ package body Sem_Ch6 is or else Present (Extra_Accessibility (P_Formal))) then Set_Extra_Accessibility - (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "F")); + (Formal, Add_Extra_Formal (Formal, Standard_Natural, E, "L")); end if; -- This label is required when skipping extra formal generation for @@ -6033,8 +6111,9 @@ package body Sem_Ch6 is when N_Aggregate => return FCL (Expressions (E1), Expressions (E2)) - and then FCL (Component_Associations (E1), - Component_Associations (E2)); + and then + FCL (Component_Associations (E1), + Component_Associations (E2)); when N_Allocator => if Nkind (Expression (E1)) = N_Qualified_Expression @@ -6104,6 +6183,38 @@ package body Sem_Ch6 is and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + when N_Case_Expression => + declare + Alt1 : Node_Id; + Alt2 : Node_Id; + + begin + if not FCE (Expression (E1), Expression (E2)) then + return False; + + else + Alt1 := First (Alternatives (E1)); + Alt2 := First (Alternatives (E2)); + loop + if Present (Alt1) /= Present (Alt2) then + return False; + elsif No (Alt1) then + return True; + end if; + + if not FCE (Expression (Alt1), Expression (Alt2)) + or else not FCL (Discrete_Choices (Alt1), + Discrete_Choices (Alt2)) + then + return False; + end if; + + Next (Alt1); + Next (Alt2); + end loop; + end if; + end; + when N_Character_Literal => return Char_Literal_Value (E1) = Char_Literal_Value (E2); @@ -6111,7 +6222,8 @@ package body Sem_Ch6 is when N_Component_Association => return FCL (Choices (E1), Choices (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Conditional_Expression => return @@ -6132,13 +6244,15 @@ package body Sem_Ch6 is when N_Function_Call => return FCE (Name (E1), Name (E2)) - and then FCL (Parameter_Associations (E1), - Parameter_Associations (E2)); + and then + FCL (Parameter_Associations (E1), + Parameter_Associations (E2)); when N_Indexed_Component => return FCE (Prefix (E1), Prefix (E2)) - and then FCL (Expressions (E1), Expressions (E2)); + and then + FCL (Expressions (E1), Expressions (E2)); when N_Integer_Literal => return (Intval (E1) = Intval (E2)); @@ -6162,12 +6276,14 @@ package body Sem_Ch6 is when N_Qualified_Expression => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Range => return FCE (Low_Bound (E1), Low_Bound (E2)) - and then FCE (High_Bound (E1), High_Bound (E2)); + and then + FCE (High_Bound (E1), High_Bound (E2)); when N_Real_Literal => return (Realval (E1) = Realval (E2)); @@ -6175,12 +6291,14 @@ package body Sem_Ch6 is when N_Selected_Component => return FCE (Prefix (E1), Prefix (E2)) - and then FCE (Selector_Name (E1), Selector_Name (E2)); + and then + FCE (Selector_Name (E1), Selector_Name (E2)); when N_Slice => return FCE (Prefix (E1), Prefix (E2)) - and then FCE (Discrete_Range (E1), Discrete_Range (E2)); + and then + FCE (Discrete_Range (E1), Discrete_Range (E2)); when N_String_Literal => declare @@ -6209,17 +6327,20 @@ package body Sem_Ch6 is when N_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); when N_Unary_Op => return Entity (E1) = Entity (E2) - and then FCE (Right_Opnd (E1), Right_Opnd (E2)); + and then + FCE (Right_Opnd (E1), Right_Opnd (E2)); when N_Unchecked_Type_Conversion => return FCE (Subtype_Mark (E1), Subtype_Mark (E2)) - and then FCE (Expression (E1), Expression (E2)); + and then + FCE (Expression (E1), Expression (E2)); -- All other node types cannot appear in this context. Strictly -- we should raise a fatal internal error. Instead we just ignore @@ -6375,8 +6496,8 @@ package body Sem_Ch6 is or else Etype (Prim) = Etype (Iface_Prim) or else not Has_Controlling_Result (Prim) then - return Type_Conformant (Prim, Iface_Prim, - Skip_Controlling_Formals => True); + return Type_Conformant + (Iface_Prim, Prim, Skip_Controlling_Formals => True); -- Case of a function returning an interface, or an access to one. -- Check that the return types correspond. @@ -6513,7 +6634,6 @@ package body Sem_Ch6 is -- instance of) a generic type. Formal := First_Formal (Prev_E); - while Present (Formal) loop F_Typ := Base_Type (Etype (Formal)); @@ -6824,8 +6944,9 @@ package body Sem_Ch6 is and then (not Is_Overriding or else not Is_Abstract_Subprogram (E)) then - Error_Msg_N ("abstract subprograms must be visible " - & "(RM 3.9.3(10))!", S); + Error_Msg_N + ("abstract subprograms must be visible " + & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function and then Is_Tagged_Type (T) @@ -7441,9 +7562,11 @@ package body Sem_Ch6 is -- E exists and is overloadable else - -- Ada 2005 (AI-251): Derivation of abstract interface primitives - -- need no check against the homonym chain. They are directly added - -- to the list of primitive operations of Derived_Type. + -- Ada 2005 (AI-251): Derivation of abstract interface primitives. + -- They are directly added to the list of primitive operations of + -- Derived_Type, unless this is a rederivation in the private part + -- of an operation that was already derived in the visible part of + -- the current package. if Ada_Version >= Ada_05 and then Present (Derived_Type) @@ -7451,7 +7574,16 @@ package body Sem_Ch6 is and then Present (Find_Dispatching_Type (Alias (S))) and then Is_Interface (Find_Dispatching_Type (Alias (S))) then - goto Add_New_Entity; + if Type_Conformant (E, S) + and then Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Parent (E) /= Parent (S) + and then Alias (E) = Alias (S) + then + Check_Operation_From_Private_View (S, E); + else + goto Add_New_Entity; + end if; end if; Check_Synchronized_Overriding (S, Overridden_Subp); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index ca5b18ad77c..b797791c24f 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -261,8 +261,7 @@ package body Sem_Ch7 is Error_Msg_N ("optional package body (not allowed in Ada 95)?", N); else - Error_Msg_N - ("spec of this package does not allow a body", N); + Error_Msg_N ("spec of this package does not allow a body", N); end if; end if; end if; @@ -2074,7 +2073,7 @@ package body Sem_Ch7 is -- but the formals are private and remain so. if Ekind (Id) = E_Function - and then Is_Operator_Symbol_Name (Chars (Id)) + and then Is_Operator_Symbol_Name (Chars (Id)) and then not Is_Hidden (Id) and then not Error_Posted (Id) then diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index c10ab2b53c4..370e2d68975 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -398,15 +398,20 @@ package body Sem_Ch8 is -- must be added to the list of actuals in any subsequent call. function Applicable_Use (Pack_Name : Node_Id) return Boolean; - -- Common code to Use_One_Package and Set_Use, to determine whether - -- use clause must be processed. Pack_Name is an entity name that - -- references the package in question. + -- Common code to Use_One_Package and Set_Use, to determine whether use + -- clause must be processed. Pack_Name is an entity name that references + -- the package in question. procedure Attribute_Renaming (N : Node_Id); -- Analyze renaming of attribute as subprogram. The renaming declaration N -- is rewritten as a subprogram body that returns the attribute reference -- applied to the formals of the function. + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id); + -- Set Entity, with style check if need be. For a discriminant reference, + -- replace by the corresponding discriminal, i.e. the parameter of the + -- initialization procedure that corresponds to the discriminant. + procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id); -- A renaming_as_body may occur after the entity of the original decla- -- ration has been frozen. In that case, the body of the new entity must @@ -893,7 +898,7 @@ package body Sem_Ch8 is Error_Msg_NE ("\?function & will be called only once", Nam, Entity (Name (Nam))); - Error_Msg_N + Error_Msg_N -- CODEFIX ("\?suggest using an initialized constant object instead", Nam); end if; @@ -910,9 +915,7 @@ package body Sem_Ch8 is then declare Loc : constant Source_Ptr := Sloc (N); - Subt : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + Subt : constant Entity_Id := Make_Temporary (Loc, 'T'); begin Remove_Side_Effects (Nam); Insert_Action (N, @@ -1315,7 +1318,8 @@ package body Sem_Ch8 is begin if not Is_Overloaded (P) then if Ekind (Etype (Nam)) /= E_Subprogram_Type - or else not Type_Conformant (Etype (Nam), New_S) then + or else not Type_Conformant (Etype (Nam), New_S) + then Error_Msg_N ("designated type does not match specification", P); else Resolve (P); @@ -1330,8 +1334,8 @@ package body Sem_Ch8 is while Present (It.Nam) loop if Ekind (It.Nam) = E_Subprogram_Type - and then Type_Conformant (It.Nam, New_S) then - + and then Type_Conformant (It.Nam, New_S) + then if Typ /= Any_Id then Error_Msg_N ("ambiguous renaming", P); return; @@ -2149,9 +2153,7 @@ package body Sem_Ch8 is -- Guard against previous errors, and omit renamings of predefined -- operators. - elsif Ekind (Old_S) /= E_Function - and then Ekind (Old_S) /= E_Procedure - then + elsif not Ekind_In (Old_S, E_Function, E_Procedure) then null; elsif Requires_Overriding (Old_S) @@ -2584,8 +2586,7 @@ package body Sem_Ch8 is ("a generic package is not allowed in a use clause", Pack_Name); else - Error_Msg_N -- CODEFIX??? - ("& is not a usable package", Pack_Name); + Error_Msg_N ("& is not a usable package", Pack_Name); end if; else @@ -2706,7 +2707,7 @@ package body Sem_Ch8 is if Warn_On_Redundant_Constructs and then Pack = Current_Scope then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible within itself?", Pack_Name, Pack); end if; @@ -2838,19 +2839,17 @@ package body Sem_Ch8 is if Aname = Name_AST_Entry then declare - Ent : Entity_Id; + Ent : constant Entity_Id := Make_Temporary (Loc, 'R', Nam); Decl : Node_Id; begin - Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Decl := Make_Object_Declaration (Loc, Defining_Identifier => Ent, - Object_Definition => + Object_Definition => New_Occurrence_Of (RTE (RE_AST_Handler), Loc), - Expression => Nam, - Constant_Present => True); + Expression => Nam, + Constant_Present => True); Set_Assignment_OK (Decl, True); Insert_Action (N, Decl); @@ -3042,6 +3041,56 @@ package body Sem_Ch8 is end if; end Check_Frozen_Renaming; + ------------------------------- + -- Set_Entity_Or_Discriminal -- + ------------------------------- + + procedure Set_Entity_Or_Discriminal (N : Node_Id; E : Entity_Id) is + P : Node_Id; + + begin + -- If the entity is not a discriminant, or else expansion is disabled, + -- simply set the entity. + + if not In_Spec_Expression + or else Ekind (E) /= E_Discriminant + or else Inside_A_Generic + then + Set_Entity_With_Style_Check (N, E); + + -- The replacement of a discriminant by the corresponding discriminal + -- is not done for a task discriminant that appears in a default + -- expression of an entry parameter. See Expand_Discriminant in exp_ch2 + -- for details on their handling. + + elsif Is_Concurrent_Type (Scope (E)) then + + P := Parent (N); + while Present (P) + and then not Nkind_In (P, N_Parameter_Specification, + N_Component_Declaration) + loop + P := Parent (P); + end loop; + + if Present (P) + and then Nkind (P) = N_Parameter_Specification + then + null; + + else + Set_Entity (N, Discriminal (E)); + end if; + + -- Otherwise, this is a discriminant in a context in which + -- it is a reference to the corresponding parameter of the + -- init proc for the enclosing type. + + else + Set_Entity (N, Discriminal (E)); + end if; + end Set_Entity_Or_Discriminal; + ----------------------------------- -- Check_In_Previous_With_Clause -- ----------------------------------- @@ -3076,8 +3125,7 @@ package body Sem_Ch8 is end loop; if Is_Child_Unit (Entity (Original_Node (Par))) then - Error_Msg_NE - ("& is not directly visible", Par, Entity (Par)); + Error_Msg_NE ("& is not directly visible", Par, Entity (Par)); else return; end if; @@ -3841,9 +3889,20 @@ package body Sem_Ch8 is Nkind (Parent (Parent (N))) = N_Use_Package_Clause then Error_Msg_Qual_Level := 99; - Error_Msg_NE ("\\missing `WITH &;`", N, Ent); + Error_Msg_NE -- CODEFIX + ("\\missing `WITH &;`", N, Ent); Error_Msg_Qual_Level := 0; end if; + + if Ekind (Ent) = E_Discriminant + and then Present (Corresponding_Discriminant (Ent)) + and then Scope (Corresponding_Discriminant (Ent)) = + Etype (Scope (Ent)) + then + Error_Msg_N + ("inherited discriminant not allowed here" & + " (RM 3.8 (12), 3.8.1 (6))!", N); + end if; end if; -- Set entity and its containing package as referenced. We @@ -3909,7 +3968,7 @@ package body Sem_Ch8 is if Chars (Lit) /= Chars (N) and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then Error_Msg_Node_2 := Lit; - Error_Msg_N + Error_Msg_N -- CODEFIX ("& is undefined, assume misspelling of &", N); Rewrite (N, New_Occurrence_Of (Lit, Sloc (N))); return; @@ -3973,7 +4032,7 @@ package body Sem_Ch8 is -- this is a very common error for beginners to make). if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then - Error_Msg_N + Error_Msg_N -- CODEFIX ("\\possible missing `WITH Ada.Text_'I'O; " & "USE Ada.Text_'I'O`!", N); @@ -3986,7 +4045,8 @@ package body Sem_Ch8 is and then Is_Known_Unit (Parent (N)) then Error_Msg_Node_2 := Selector_Name (Parent (N)); - Error_Msg_N ("\\missing `WITH &.&;`", Prefix (Parent (N))); + Error_Msg_N -- CODEFIX + ("\\missing `WITH &.&;`", Prefix (Parent (N))); end if; -- Now check for possible misspellings @@ -4372,8 +4432,18 @@ package body Sem_Ch8 is return; end if; - Set_Entity (N, E); - -- Why no Style_Check here??? + -- Set the entity. Note that the reason we call Set_Entity for the + -- overloadable case, as opposed to Set_Entity_With_Style_Check is + -- that in the overloaded case, the initial call can set the wrong + -- homonym. The call that sets the right homonym is in Sem_Res and + -- that call does use Set_Entity_With_Style_Check, so we don't miss + -- a style check. + + if Is_Overloadable (E) then + Set_Entity (N, E); + else + Set_Entity_With_Style_Check (N, E); + end if; if Is_Type (E) then Set_Etype (N, E); @@ -4483,58 +4553,7 @@ package body Sem_Ch8 is Check_Nested_Access (E); end if; - -- Set Entity, with style check if need be. For a discriminant - -- reference, replace by the corresponding discriminal, i.e. the - -- parameter of the initialization procedure that corresponds to - -- the discriminant. If this replacement is being performed, there - -- is no style check to perform. - - -- This replacement must not be done if we are currently - -- processing a generic spec or body, because the discriminal - -- has not been not generated in this case. - - -- The replacement is also skipped if we are in special - -- spec-expression mode. Why is this skipped in this case ??? - - if not In_Spec_Expression - or else Ekind (E) /= E_Discriminant - or else Inside_A_Generic - then - Set_Entity_With_Style_Check (N, E); - - -- The replacement is not done either for a task discriminant that - -- appears in a default expression of an entry parameter. See - -- Expand_Discriminant in exp_ch2 for details on their handling. - - elsif Is_Concurrent_Type (Scope (E)) then - declare - P : Node_Id; - - begin - P := Parent (N); - while Present (P) - and then not Nkind_In (P, N_Parameter_Specification, - N_Component_Declaration) - loop - P := Parent (P); - end loop; - - if Present (P) - and then Nkind (P) = N_Parameter_Specification - then - null; - else - Set_Entity (N, Discriminal (E)); - end if; - end; - - -- Otherwise, this is a discriminant in a context in which - -- it is a reference to the corresponding parameter of the - -- init proc for the enclosing type. - - else - Set_Entity (N, Discriminal (E)); - end if; + Set_Entity_Or_Discriminal (N, E); end if; end; end Find_Direct_Name; @@ -4724,7 +4743,8 @@ package body Sem_Ch8 is else Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing `WITH &;`", Selector, Candidate); + Error_Msg_NE -- CODEFIX + ("missing `WITH &;`", Selector, Candidate); Error_Msg_Qual_Level := 0; end if; @@ -4755,9 +4775,9 @@ package body Sem_Ch8 is exit when S = Standard_Standard; - if Ekind (S) = E_Function - or else Ekind (S) = E_Package - or else Ekind (S) = E_Procedure + if Ekind_In (S, E_Function, + E_Package, + E_Procedure) then P := Generic_Parent (Specification (Unit_Declaration_Node (S))); @@ -4781,7 +4801,8 @@ package body Sem_Ch8 is if Is_Known_Unit (N) then if not Error_Posted (N) then Error_Msg_Node_2 := Selector; - Error_Msg_N ("missing `WITH &.&;`", Prefix (N)); + Error_Msg_N -- CODEFIX + ("missing `WITH &.&;`", Prefix (N)); end if; -- If this is a selection from a dummy package, then suppress @@ -4862,7 +4883,8 @@ package body Sem_Ch8 is (Generic_Parent (Parent (Entity (Prefix (N))))) then Error_Msg_Node_2 := Selector; - Error_Msg_N ("\missing `WITH &.&;`", Prefix (N)); + Error_Msg_N -- CODEFIX + ("\missing `WITH &.&;`", Prefix (N)); end if; end if; end if; @@ -4927,7 +4949,7 @@ package body Sem_Ch8 is if Has_Homonym (Id) then Set_Entity (N, Id); else - Set_Entity_With_Style_Check (N, Id); + Set_Entity_Or_Discriminal (N, Id); Generate_Reference (Id, N); end if; @@ -5154,11 +5176,11 @@ package body Sem_Ch8 is function Report_Overload return Entity_Id is begin if Is_Actual then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("ambiguous actual subprogram&, " & "possible interpretations:", N, Nam); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("ambiguous subprogram, " & "possible interpretations:", N); end if; @@ -5738,7 +5760,7 @@ package body Sem_Ch8 is and then Base_Type (Typ) = Typ and then Warn_On_Redundant_Constructs then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?redundant attribute, & is its own base type", N, Typ); end if; @@ -6021,12 +6043,45 @@ package body Sem_Ch8 is Change_Selected_Component_To_Expanded_Name (N); end if; - Add_One_Interp (N, Predef_Op, T); + -- If the context is an unanalyzed function call, determine whether + -- a binary or unary interpretation is required. + + if Nkind (Parent (N)) = N_Indexed_Component then + declare + Is_Binary_Call : constant Boolean := + Present + (Next (First (Expressions (Parent (N))))); + Is_Binary_Op : constant Boolean := + First_Entity + (Predef_Op) /= Last_Entity (Predef_Op); + Predef_Op2 : constant Entity_Id := Homonym (Predef_Op); + + begin + if Is_Binary_Call then + if Is_Binary_Op then + Add_One_Interp (N, Predef_Op, T); + else + Add_One_Interp (N, Predef_Op2, T); + end if; - -- For operators with unary and binary interpretations, add both + else + if not Is_Binary_Op then + Add_One_Interp (N, Predef_Op, T); + else + Add_One_Interp (N, Predef_Op2, T); + end if; + end if; + end; + + else + Add_One_Interp (N, Predef_Op, T); - if Present (Homonym (Predef_Op)) then - Add_One_Interp (N, Homonym (Predef_Op), T); + -- For operators with unary and binary interpretations, if + -- context is not a call, add both + + if Present (Homonym (Predef_Op)) then + Add_One_Interp (N, Homonym (Predef_Op), T); + end if; end if; -- The node is a reference to a predefined operator, and @@ -6223,9 +6278,7 @@ package body Sem_Ch8 is Next_Formal (Old_F); end loop; - if Ekind (Old_S) = E_Function - or else Ekind (Old_S) = E_Enumeration_Literal - then + if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then Set_Etype (New_S, Etype (Old_S)); end if; end if; @@ -6541,7 +6594,7 @@ package body Sem_Ch8 is if Present (Redundant) then Error_Msg_Sloc := Sloc (Prev_Use); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous use clause #?", Redundant, Pack_Name); end if; @@ -7519,14 +7572,14 @@ package body Sem_Ch8 is if Unit1 = Unit2 then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; elsif Nkind (Unit1) = N_Subunit then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Clause1, T); return; @@ -7536,7 +7589,7 @@ package body Sem_Ch8 is and then Nkind (Unit1) /= N_Subunit then Error_Msg_Sloc := Sloc (Clause1); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Current_Use_Clause (T), T); return; @@ -7587,7 +7640,7 @@ package body Sem_Ch8 is end; end if; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use_type_clause #?", Err_No, Id); @@ -7596,7 +7649,7 @@ package body Sem_Ch8 is -- level. In this case we don't have location information. else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use type clause?", Id, T); end if; @@ -7606,7 +7659,7 @@ package body Sem_Ch8 is -- where we do not have the location information available. else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " & "use type clause?", Id, T); end if; @@ -7615,7 +7668,7 @@ package body Sem_Ch8 is elsif In_Use (Scope (T)) then Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T))); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible through package use clause #?", Id, T); @@ -7623,7 +7676,7 @@ package body Sem_Ch8 is else Error_Msg_Node_2 := Scope (T); - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("& is already use-visible inside package &?", Id, T); end if; end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 9a242d5eedd..21f80dfd713 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -30,7 +30,6 @@ with Errout; use Errout; with Exp_Ch9; use Exp_Ch9; with Elists; use Elists; with Freeze; use Freeze; -with Itypes; use Itypes; with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; @@ -167,73 +166,6 @@ package body Sem_Ch9 is Kind : Entity_Kind; Task_Nam : Entity_Id; - ----------------------- - -- Actual_Index_Type -- - ----------------------- - - function Actual_Index_Type (E : Entity_Id) return Entity_Id; - -- If the bounds of an entry family depend on task discriminants, create - -- a new index type where a discriminant is replaced by the local - -- variable that renames it in the task body. - - ----------------------- - -- Actual_Index_Type -- - ----------------------- - - function Actual_Index_Type (E : Entity_Id) return Entity_Id is - Typ : constant Entity_Id := Entry_Index_Type (E); - Lo : constant Node_Id := Type_Low_Bound (Typ); - Hi : constant Node_Id := Type_High_Bound (Typ); - New_T : Entity_Id; - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; - -- If bound is discriminant reference, replace with corresponding - -- local variable of the same name. - - ----------------------------- - -- Actual_Discriminant_Ref -- - ----------------------------- - - function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is - Typ : constant Entity_Id := Etype (Bound); - Ref : Node_Id; - begin - if not Is_Entity_Name (Bound) - or else Ekind (Entity (Bound)) /= E_Discriminant - then - return Bound; - else - Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound))); - Analyze (Ref); - Resolve (Ref, Typ); - return Ref; - end if; - end Actual_Discriminant_Ref; - - -- Start of processing for Actual_Index_Type - - begin - if not Has_Discriminants (Task_Nam) - or else (not Is_Entity_Name (Lo) - and then not Is_Entity_Name (Hi)) - then - return Entry_Index_Type (E); - else - New_T := Create_Itype (Ekind (Typ), N); - Set_Etype (New_T, Base_Type (Typ)); - Set_Size_Info (New_T, Typ); - Set_RM_Size (New_T, RM_Size (Typ)); - Set_Scalar_Range (New_T, - Make_Range (Sloc (N), - Low_Bound => Actual_Discriminant_Ref (Lo), - High_Bound => Actual_Discriminant_Ref (Hi))); - - return New_T; - end if; - end Actual_Index_Type; - - -- Start of processing for Analyze_Accept_Statement - begin Tasking_Used := True; @@ -370,7 +302,7 @@ package body Sem_Ch9 is Error_Msg_N ("missing entry index in accept for entry family", N); else Analyze_And_Resolve (Index, Entry_Index_Type (E)); - Apply_Range_Check (Index, Actual_Index_Type (E)); + Apply_Range_Check (Index, Entry_Index_Type (E)); end if; elsif Present (Index) then @@ -991,9 +923,7 @@ package body Sem_Ch9 is procedure Analyze_Entry_Index_Specification (N : Node_Id) is Iden : constant Node_Id := Defining_Identifier (N); Def : constant Node_Id := Discrete_Subtype_Definition (N); - Loop_Id : constant Entity_Id := - Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name ('L')); + Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); begin Tasking_Used := True; @@ -1174,9 +1104,7 @@ package body Sem_Ch9 is E := First_Entity (Current_Scope); while Present (E) loop - if Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - then + if Ekind_In (E, E_Function, E_Procedure) then Set_Convention (E, Convention_Protected); elsif Is_Task_Type (Etype (E)) @@ -1248,16 +1176,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of protected type while inside a generic. - -- The corresponding record is needed for various semantic checks. - - if Ada_Version >= Ada_05 - and then Inside_A_Generic - then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the @@ -1343,9 +1261,7 @@ package body Sem_Ch9 is Enclosing := Scope_Stack.Table (J).Entity; exit when Is_Entry (Enclosing); - if Ekind (Enclosing) /= E_Block - and then Ekind (Enclosing) /= E_Loop - then + if not Ekind_In (Enclosing, E_Block, E_Loop) then Error_Msg_N ("requeue must appear within accept or entry body", N); return; end if; @@ -1576,10 +1492,7 @@ package body Sem_Ch9 is -- perform an unconditional goto so that any further -- references will not occur anyway. - if Ekind (Ent) = E_Out_Parameter - or else - Ekind (Ent) = E_In_Out_Parameter - then + if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then Set_Never_Set_In_Source (Ent, False); Set_Is_True_Constant (Ent, False); end if; @@ -2053,15 +1966,6 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); - -- Perform minimal expansion of the task type while inside a generic - -- context. The corresponding record is needed for various semantic - -- checks. - - if Inside_A_Generic then - Insert_After_And_Analyze (N, - Build_Corresponding_Record (N, T, Sloc (T))); - end if; - if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; @@ -2433,15 +2337,17 @@ package body Sem_Ch9 is Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by full type " & - "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); + Error_Msg_NE + ("interface & not implemented by full type " & + "(RM-2005 7.3 (7.3/2))", Priv_T, Iface); end if; Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); if Present (Iface) then - Error_Msg_NE ("interface & not implemented by partial " & - "view (RM-2005 7.3 (7.3/2))", T, Iface); + Error_Msg_NE + ("interface & not implemented by partial " & + "view (RM-2005 7.3 (7.3/2))", T, Iface); end if; end if; end if; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 9c9da627ee0..a21337bb600 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -175,10 +175,7 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - if Ekind (Subp) = E_Function - or else - Ekind (Subp) = E_Generic_Function - then + if Ekind_In (Subp, E_Function, E_Generic_Function) then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then @@ -643,8 +640,8 @@ package body Sem_Disp is end if; if Present (Func) and then Is_Abstract_Subprogram (Func) then - Error_Msg_N ( - "call to abstract function must be dispatching", N); + Error_Msg_N + ("call to abstract function must be dispatching", N); end if; end if; @@ -673,25 +670,22 @@ package body Sem_Disp is Body_Is_Last_Primitive : Boolean := False; begin - if Ekind (Subp) /= E_Procedure and then Ekind (Subp) /= E_Function then + if not Ekind_In (Subp, E_Procedure, E_Function) then return; end if; Set_Is_Dispatching_Operation (Subp, False); Tagged_Type := Find_Dispatching_Type (Subp); - -- Ada 2005 (AI-345) + -- Ada 2005 (AI-345): Use the corresponding record (if available). + -- Required because primitives of concurrent types are be attached + -- to the corresponding record (not to the concurrent type). - if Ada_Version = Ada_05 + if Ada_Version >= Ada_05 and then Present (Tagged_Type) and then Is_Concurrent_Type (Tagged_Type) + and then Present (Corresponding_Record_Type (Tagged_Type)) then - -- Protect the frontend against previously detected errors - - if No (Corresponding_Record_Type (Tagged_Type)) then - return; - end if; - Tagged_Type := Corresponding_Record_Type (Tagged_Type); end if; @@ -749,7 +743,7 @@ package body Sem_Disp is and then not In_Instance then Error_Msg_N ("?declaration of& is too late!", Subp); - Error_Msg_NE + Error_Msg_NE -- CODEFIX?? ("\spec should appear immediately after declaration of &!", Subp, Typ); exit; @@ -790,7 +784,7 @@ package body Sem_Disp is and then not Comes_From_Source (Subp) and then not Has_Dispatching_Parent then - -- Complete decoration if internally built subprograms that override + -- Complete decoration of internally built subprograms that override -- a dispatching primitive. These entities correspond with the -- following cases: @@ -1071,6 +1065,18 @@ package body Sem_Disp is end if; end if; + -- If the tagged type is a concurrent type then we must be compiling + -- with no code generation (we are either compiling a generic unit or + -- compiling under -gnatc mode) because we have previously tested that + -- no serious errors has been reported. In this case we do not add the + -- primitive to the list of primitives of Tagged_Type but we leave the + -- primitive decorated as a dispatching operation to be able to analyze + -- and report errors associated with the Object.Operation notation. + + elsif Is_Concurrent_Type (Tagged_Type) then + pragma Assert (not Expander_Active); + null; + -- If no old subprogram, then we add this as a dispatching operation, -- but we avoid doing this if an error was posted, to prevent annoying -- cascaded errors. @@ -1499,7 +1505,7 @@ package body Sem_Disp is -- For subprograms internally generated by derivations of tagged types -- use the alias subprogram as a reference to locate the dispatching - -- type of Subp + -- type of Subp. elsif not Comes_From_Source (Subp) and then Present (Alias (Subp)) @@ -1703,7 +1709,28 @@ package body Sem_Disp is return; end if; - Replace_Elmt (Elmt, New_Op); + -- The location of entities that come from source in the list of + -- primitives of the tagged type must follow their order of occurrence + -- in the sources to fulfill the C++ ABI. If the overriden entity is a + -- primitive of an interface that is not an ancestor of this tagged + -- type (that is, it is an entity added to the list of primitives by + -- Derive_Interface_Progenitors), then we must append the new entity + -- at the end of the list of primitives. + + if Present (Alias (Prev_Op)) + and then Is_Interface (Find_Dispatching_Type (Alias (Prev_Op))) + and then not Is_Ancestor (Find_Dispatching_Type (Alias (Prev_Op)), + Tagged_Type) + then + Remove_Elmt (Primitive_Operations (Tagged_Type), Elmt); + Append_Elmt (New_Op, Primitive_Operations (Tagged_Type)); + + -- The new primitive replaces the overriden entity. Required to ensure + -- that overriding primitive is assigned the same dispatch table slot. + + else + Replace_Elmt (Elmt, New_Op); + end if; if Ada_Version >= Ada_05 and then Has_Interfaces (Tagged_Type) diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index c0195ecd4fd..3877826ca29 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,7 +46,12 @@ package Sem_Disp is -- if it has a parameter of this type and is defined at a proper place for -- primitive operations (new primitives are only defined in package spec, -- overridden operation can be defined in any scope). If Old_Subp is not - -- Empty we are in the overriding case. + -- Empty we are in the overriding case. If the tagged type associated with + -- Subp is a concurrent type (case that occurs when the type is declared in + -- a generic because the analysis of generics disables generation of the + -- corresponding record) then this routine does does not add "Subp" to the + -- list of primitive operations but leaves Subp decorated as dispatching + -- operation to enable checks associated with the Object.Operation notation procedure Check_Operation_From_Incomplete_Type (Subp : Entity_Id; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 111a9d2d0d6..64b85758a10 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -451,9 +451,7 @@ package body Sem_Dist is -- True iff this RAS has an access formal parameter (see -- Exp_Dist.Add_RAS_Dereference_TSS for details). - Subpkg : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); Subpkg_Decl : Node_Id; Subpkg_Body : Node_Id; Vis_Decls : constant List_Id := New_List; @@ -464,16 +462,14 @@ package body Sem_Dist is New_External_Name (Chars (User_Type), 'R')); Full_Obj_Type : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars (Obj_Type)); + Make_Defining_Identifier (Loc, Chars (Obj_Type)); RACW_Type : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (User_Type), 'P')); Fat_Type : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars (User_Type)); + Make_Defining_Identifier (Loc, Chars (User_Type)); Fat_Type_Decl : Node_Id; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index a07e9839d1b..74aac9e5e0e 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2010, 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- -- @@ -599,9 +599,7 @@ package body Sem_Elab is -- No checks needed for pure or preelaborated compilation units - if Is_Pure (E_Scope) - or else Is_Preelaborated (E_Scope) - then + if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then return; end if; @@ -2432,7 +2430,8 @@ package body Sem_Elab is and then not Elaboration_Checks_Suppressed (Task_Scope) then Error_Msg_Node_2 := Task_Scope; - Error_Msg_NE ("activation of an instance of task type&" & + Error_Msg_NE + ("activation of an instance of task type&" & " requires pragma Elaborate_All on &?", N, Ent); end if; @@ -3013,10 +3012,7 @@ package body Sem_Elab is -- Check for case of body entity -- Why is the check for E_Void needed??? - if Ekind (E) = E_Void - or else Ekind (E) = E_Subprogram_Body - or else Ekind (E) = E_Package_Body - then + if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then Decl := E; loop @@ -3047,17 +3043,17 @@ package body Sem_Elab is if No (Corresponding_Body (N)) then declare - Loc : constant Source_Ptr := Sloc (N); - B : Node_Id; - Formals : constant List_Id := - Copy_Parameter_List (Ent); - Nam : constant Entity_Id := - Make_Defining_Identifier (Loc, Chars (Ent)); - Spec : Node_Id; - Stats : constant List_Id := - New_List - (Make_Raise_Program_Error (Loc, - Reason => PE_Access_Before_Elaboration)); + Loc : constant Source_Ptr := Sloc (N); + B : Node_Id; + Formals : constant List_Id := Copy_Parameter_List (Ent); + Nam : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Ent)); + Spec : Node_Id; + Stats : constant List_Id := + New_List + (Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + begin if Ekind (Ent) = E_Function then Spec := diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index e4c99fc01b6..c160c8e419a 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,9 @@ with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; +with Opt; use Opt; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinput; use Sinput; @@ -234,6 +236,7 @@ package body Sem_Elim is Elmt : Access_Elim_Data; Scop : Entity_Id; Form : Entity_Id; + Up : Nat; begin if No_Elimination then @@ -286,21 +289,49 @@ package body Sem_Elim is goto Continue; end if; - -- Find enclosing unit + -- Find enclosing unit, and verify that its name and those of its + -- parents match. Scop := Cunit_Entity (Current_Sem_Unit); -- Now see if compilation unit matches - for J in reverse Elmt.Unit_Name'Range loop + Up := Elmt.Unit_Name'Last; + + -- If we are within a subunit, the name in the pragma has been + -- parsed as a child unit, but the current compilation unit is in + -- fact the parent in which the subunit is embedded. We must skip + -- the first name which is that of the subunit to match the pragma + -- specification. Body may be that of a package or subprogram. + + declare + Par : Node_Id; + + begin + Par := Parent (E); + while Present (Par) loop + if Nkind (Par) = N_Subunit then + if Chars (Defining_Entity (Proper_Body (Par))) = + Elmt.Unit_Name (Up) + then + Up := Up - 1; + exit; + + else + goto Continue; + end if; + end if; + + Par := Parent (Par); + end loop; + end; + + for J in reverse Elmt.Unit_Name'First .. Up loop if Elmt.Unit_Name (J) /= Chars (Scop) then goto Continue; end if; Scop := Scope (Scop); - while Ekind (Scop) = E_Block loop - Scop := Scope (Scop); - end loop; if Scop /= Standard_Standard and then J = 1 then goto Continue; @@ -311,8 +342,59 @@ package body Sem_Elim is goto Continue; end if; - -- Check for case of given entity is a library level subprogram - -- and we have the single parameter Eliminate case, a match! + if Present (Elmt.Entity_Node) + and then Elmt.Entity_Scope /= null + then + -- Check that names of enclosing scopes match. Skip blocks and + -- wrapper package of subprogram instances, which do not appear + -- in the pragma. + + Scop := Scope (E); + + for J in reverse Elmt.Entity_Scope'Range loop + while Ekind (Scop) = E_Block + or else + (Ekind (Scop) = E_Package + and then Is_Wrapper_Package (Scop)) + loop + Scop := Scope (Scop); + end loop; + + if Elmt.Entity_Scope (J) /= Chars (Scop) then + if Ekind (Scop) /= E_Protected_Type + or else Comes_From_Source (Scop) + then + goto Continue; + + -- For simple protected declarations, retrieve the source + -- name of the object, which appeared in the Eliminate + -- pragma. + + else + declare + Decl : constant Node_Id := + Original_Node (Parent (Scop)); + + begin + if Elmt.Entity_Scope (J) /= + Chars (Defining_Identifier (Decl)) + then + if J > 0 then + null; + end if; + goto Continue; + end if; + end; + end if; + + end if; + + Scop := Scope (Scop); + end loop; + end if; + + -- If given entity is a library level subprogram and pragma had a + -- single parameter, a match! if Is_Compilation_Unit (E) and then Is_Subprogram (E) @@ -332,9 +414,8 @@ package body Sem_Elim is -- Check for case of subprogram - elsif Ekind (E) = E_Function - or else Ekind (E) = E_Procedure - then + elsif Ekind_In (E, E_Function, E_Procedure) then + -- If Source_Location present, then see if it matches if Elmt.Source_Location /= No_Name then @@ -642,7 +723,20 @@ package body Sem_Elim is Enclosing_Subp := Enclosing_Subprogram (Enclosing_Subp); end loop; - Eliminate_Error_Msg (N, Ultimate_Subp); + -- Emit error, unless we are within an instance body and the expander + -- is disabled, indicating an instance within an enclosing generic. + -- In an instance, the ultimate alias is an internal entity, so place + -- the message on the original subprogram. + + if In_Instance_Body and then not Expander_Active then + null; + + elsif Comes_From_Source (Ultimate_Subp) then + Eliminate_Error_Msg (N, Ultimate_Subp); + + else + Eliminate_Error_Msg (N, S); + end if; end if; end Check_For_Eliminated_Subprogram; @@ -673,7 +767,9 @@ package body Sem_Elim is -- Otherwise should not fall through, entry should be in table else - raise Program_Error; + Error_Msg_NE + ("subprogram& is called but its alias is eliminated", N, E); + -- raise Program_Error; end if; end Eliminate_Error_Msg; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 13751d21d75..84bb34a66f2 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,6 +31,7 @@ with Elists; use Elists; with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; @@ -126,6 +127,10 @@ package body Sem_Eval is -- This is the actual cache, with entries consisting of node/value pairs, -- and the impossible value Node_High_Bound used for unset entries. + type Range_Membership is (In_Range, Out_Of_Range, Unknown); + -- Range membership may either be statically known to be in range or out + -- of range, or not statically known. Used for Test_In_Range below. + ----------------------- -- Local Subprograms -- ----------------------- @@ -176,6 +181,15 @@ package body Sem_Eval is -- used for producing the result of the static evaluation of the -- logical operators + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; + -- Check whether an arithmetic operation with universal operands which + -- is a rewritten function call with an explicit scope indication is + -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one + -- visible numeric type declared in P and the context does not impose a + -- type on the result (e.g. in the expression of a type conversion). + -- If ambiguous, emit an error and return Empty, else return the result + -- type of the operator. + procedure Test_Expression_Is_Foldable (N : Node_Id; Op1 : Node_Id; @@ -210,6 +224,18 @@ package body Sem_Eval is -- Same processing, except applies to an expression N with two operands -- Op1 and Op2. + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership; + -- Common processing for Is_In_Range and Is_Out_Of_Range: + -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time + -- that expression N is known to be in or out of range of the subtype Typ. + -- If not compile time known, Unknown is returned. + -- See documentation of Is_In_Range for complete description of parameters. + procedure To_Bits (U : Uint; B : out Bits); -- Converts a Uint value to a bit string of length B'Length @@ -1430,6 +1456,7 @@ package body Sem_Eval is Right : constant Node_Id := Right_Opnd (N); Ltype : constant Entity_Id := Etype (Left); Rtype : constant Entity_Id := Etype (Right); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; @@ -1442,6 +1469,13 @@ package body Sem_Eval is return; end if; + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- Fold for cases where both operands are of integer type if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then @@ -1548,9 +1582,9 @@ package body Sem_Eval is Fold_Uint (N, Result, Stat); end; - -- Cases where at least one operand is a real. We handle the cases - -- of both reals, or mixed/real integer cases (the latter happen - -- only for divide and multiply, and the result is always real). + -- Cases where at least one operand is a real. We handle the cases of + -- both reals, or mixed/real integer cases (the latter happen only for + -- divide and multiply, and the result is always real). elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then declare @@ -1593,6 +1627,14 @@ package body Sem_Eval is Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Arithmetic_Op; ---------------------------- @@ -1632,10 +1674,7 @@ package body Sem_Eval is and then Present (Alias (Entity (Name (N)))) and then Is_Enumeration_Type (Base_Type (Typ)) then - Lit := Alias (Entity (Name (N))); - while Present (Alias (Lit)) loop - Lit := Alias (Lit); - end loop; + Lit := Ultimate_Alias (Entity (Name (N))); if Ekind (Lit) = E_Enumeration_Literal then if Base_Type (Etype (Lit)) /= Base_Type (Typ) then @@ -1650,6 +1689,27 @@ package body Sem_Eval is end if; end Eval_Call; + -------------------------- + -- Eval_Case_Expression -- + -------------------------- + + -- Right now we do not attempt folding of any case expressions, and the + -- language does not require it, so the only required processing is to + -- do the check for all expressions appearing in the case expression. + + procedure Eval_Case_Expression (N : Node_Id) is + Alt : Node_Id; + + begin + Check_Non_Static_Context (Expression (N)); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + Check_Non_Static_Context (Expression (Alt)); + Next (Alt); + end loop; + end Eval_Case_Expression; + ------------------------ -- Eval_Concatenation -- ------------------------ @@ -1767,18 +1827,79 @@ package body Sem_Eval is -- Eval_Conditional_Expression -- --------------------------------- - -- This GNAT internal construct can never be statically folded, so the - -- only required processing is to do the check for non-static context - -- for the two expression operands. + -- We can fold to a static expression if the condition and both constituent + -- expressions are static. Otherwise, the only required processing is to do + -- the check for non-static context for the then and else expressions. procedure Eval_Conditional_Expression (N : Node_Id) is - Condition : constant Node_Id := First (Expressions (N)); - Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); + Condition : constant Node_Id := First (Expressions (N)); + Then_Expr : constant Node_Id := Next (Condition); + Else_Expr : constant Node_Id := Next (Then_Expr); + Result : Node_Id; + Non_Result : Node_Id; + + Rstat : constant Boolean := + Is_Static_Expression (Condition) + and then + Is_Static_Expression (Then_Expr) + and then + Is_Static_Expression (Else_Expr); begin - Check_Non_Static_Context (Then_Expr); - Check_Non_Static_Context (Else_Expr); + -- If any operand is Any_Type, just propagate to result and do not try + -- to fold, this prevents cascaded errors. + + if Etype (Condition) = Any_Type or else + Etype (Then_Expr) = Any_Type or else + Etype (Else_Expr) = Any_Type + then + Set_Etype (N, Any_Type); + Set_Is_Static_Expression (N, False); + return; + + -- Static case where we can fold. Note that we don't try to fold cases + -- where the condition is known at compile time, but the result is + -- non-static. This avoids possible cases of infinite recursion where + -- the expander puts in a redundant test and we remove it. Instead we + -- deal with these cases in the expander. + + elsif Rstat then + + -- Select result operand + + if Is_True (Expr_Value (Condition)) then + Result := Then_Expr; + Non_Result := Else_Expr; + else + Result := Else_Expr; + Non_Result := Then_Expr; + end if; + + -- Note that it does not matter if the non-result operand raises a + -- Constraint_Error, but if the result raises constraint error then + -- we replace the node with a raise constraint error. This will + -- properly propagate Raises_Constraint_Error since this flag is + -- set in Result. + + if Raises_Constraint_Error (Result) then + Rewrite_In_Raise_CE (N, Result); + Check_Non_Static_Context (Non_Result); + + -- Otherwise the result operand replaces the original node + + else + Rewrite (N, Relocate_Node (Result)); + end if; + + -- Case of condition not known at compile time + + else + Check_Non_Static_Context (Condition); + Check_Non_Static_Context (Then_Expr); + Check_Non_Static_Context (Else_Expr); + end if; + + Set_Is_Static_Expression (N, Rstat); end Eval_Conditional_Expression; ---------------------- @@ -2069,8 +2190,7 @@ package body Sem_Eval is Right_Int : constant Uint := Expr_Value (Right); begin - - -- VMS includes bitwise operations on signed types. + -- VMS includes bitwise operations on signed types if Is_Modular_Integer_Type (Etype (N)) or else Is_VMS_Operator (Entity (N)) @@ -2149,9 +2269,7 @@ package body Sem_Eval is -- Ignore if error in either operand, except to make sure that Any_Type -- is properly propagated to avoid junk cascaded errors. - if Etype (Left) = Any_Type - or else Etype (Right) = Any_Type - then + if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then Set_Etype (N, Any_Type); return; end if; @@ -2224,7 +2342,8 @@ package body Sem_Eval is declare Typlen : constant Uint := String_Type_Len (Etype (Right)); Strlen : constant Uint := - UI_From_Int (String_Length (Strval (Get_String_Val (Left)))); + UI_From_Int + (String_Length (Strval (Get_String_Val (Left)))); begin Result := (Typlen = Strlen); end; @@ -2257,6 +2376,7 @@ package body Sem_Eval is end if; Fold_Uint (N, Test (Result), True); + Warn_On_Known_Condition (N); end Eval_Membership_Op; @@ -2316,8 +2436,8 @@ package body Sem_Eval is Result : Uint; begin - -- Exponentiation of an integer raises the exception - -- Constraint_Error for a negative exponent (RM 4.5.6) + -- Exponentiation of an integer raises Constraint_Error for a + -- negative exponent (RM 4.5.6). if Right_Int < 0 then Apply_Compile_Time_Constraint_Error @@ -2432,9 +2552,9 @@ package body Sem_Eval is begin -- Can only fold if target is string or scalar and subtype is static. - -- Also, do not fold if our parent is an allocator (this is because - -- the qualified expression is really part of the syntactic structure - -- of an allocator, and we do not want to end up with something that + -- Also, do not fold if our parent is an allocator (this is because the + -- qualified expression is really part of the syntactic structure of an + -- allocator, and we do not want to end up with something that -- corresponds to "new 1" where the 1 is the result of folding a -- qualified expression). @@ -2534,14 +2654,15 @@ package body Sem_Eval is -- Eval_Relational_Op -- ------------------------ - -- Relational operations are static functions, so the result is static - -- if both operands are static (RM 4.9(7), 4.9(20)), except that for - -- strings, the result is never static, even if the operands are. + -- Relational operations are static functions, so the result is static if + -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings, + -- the result is never static, even if the operands are. procedure Eval_Relational_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Typ : constant Entity_Id := Etype (Left); + Otype : Entity_Id := Empty; Result : Boolean; Stat : Boolean; Fold : Boolean; @@ -2620,7 +2741,7 @@ package body Sem_Eval is -- entity name, and the two X's are the same and K1 and K2 are -- known at compile time, in this case, the length can also be -- computed at compile time, even though the bounds are not - -- known. A common case of this is e.g. (X'First..X'First+5). + -- known. A common case of this is e.g. (X'First .. X'First+5). Extract_Length : declare procedure Decompose_Expr @@ -2650,17 +2771,37 @@ package body Sem_Eval is if Nkind (Expr) = N_Op_Add and then Compile_Time_Known_Value (Right_Opnd (Expr)) then - Exp := Left_Opnd (Expr); + Exp := Left_Opnd (Expr); Cons := Expr_Value (Right_Opnd (Expr)); elsif Nkind (Expr) = N_Op_Subtract and then Compile_Time_Known_Value (Right_Opnd (Expr)) then - Exp := Left_Opnd (Expr); + Exp := Left_Opnd (Expr); Cons := -Expr_Value (Right_Opnd (Expr)); + -- If the bound is a constant created to remove side + -- effects, recover original expression to see if it has + -- one of the recognizable forms. + + elsif Nkind (Expr) = N_Identifier + and then not Comes_From_Source (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Constant + and then + Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Exp := Expression (Parent (Entity (Expr))); + Decompose_Expr (Exp, Ent, Kind, Cons); + + -- If original expression includes an entity, create a + -- reference to it for use below. + + if Present (Ent) then + Exp := New_Occurrence_Of (Ent, Sloc (Ent)); + end if; + else - Exp := Expr; + Exp := Expr; Cons := Uint_0; end if; @@ -2669,8 +2810,10 @@ package body Sem_Eval is if Nkind (Exp) = N_Attribute_Reference then if Attribute_Name (Exp) = Name_First then Kind := 'F'; + elsif Attribute_Name (Exp) = Name_Last then Kind := 'L'; + else Ent := Empty; return; @@ -2751,6 +2894,17 @@ package body Sem_Eval is Set_Is_Static_Expression (N, False); end if; + -- For operators on universal numeric types called as functions with + -- an explicit scope, determine appropriate specific numeric type, and + -- diagnose possible ambiguity. + + if Is_Universal_Numeric_Type (Etype (Left)) + and then + Is_Universal_Numeric_Type (Etype (Right)) + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- For static real type expressions, we cannot use Compile_Time_Compare -- since it worries about run-time results which are not exact. @@ -2850,6 +3004,13 @@ package body Sem_Eval is Fold_Uint (N, Test (Result), Stat); end if; + -- For the case of a folded relational operator on a specific numeric + -- type, freeze operand type now. + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; + Warn_On_Known_Condition (N); end Eval_Relational_Op; @@ -2857,9 +3018,9 @@ package body Sem_Eval is -- Eval_Shift -- ---------------- - -- Shift operations are intrinsic operations that can never be static, - -- so the only processing required is to perform the required check for - -- a non static context for the two operands. + -- Shift operations are intrinsic operations that can never be static, so + -- the only processing required is to perform the required check for a non + -- static context for the two operands. -- Actually we could do some compile time evaluation here some time ??? @@ -2873,24 +3034,24 @@ package body Sem_Eval is -- Eval_Short_Circuit -- ------------------------ - -- A short circuit operation is potentially static if both operands - -- are potentially static (RM 4.9 (13)) + -- A short circuit operation is potentially static if both operands are + -- potentially static (RM 4.9 (13)). procedure Eval_Short_Circuit (N : Node_Id) is Kind : constant Node_Kind := Nkind (N); Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Left_Int : Uint; - Rstat : constant Boolean := - Is_Static_Expression (Left) - and then Is_Static_Expression (Right); + + Rstat : constant Boolean := + Is_Static_Expression (Left) + and then + Is_Static_Expression (Right); begin -- Short circuit operations are never static in Ada 83 - if Ada_Version = Ada_83 - and then Comes_From_Source (N) - then + if Ada_Version = Ada_83 and then Comes_From_Source (N) then Check_Non_Static_Context (Left); Check_Non_Static_Context (Right); return; @@ -2901,8 +3062,8 @@ package body Sem_Eval is -- are a special case, they can still be foldable, even if the right -- operand raises constraint error. - -- If either operand is Any_Type, just propagate to result and - -- do not try to fold, this prevents cascaded errors. + -- If either operand is Any_Type, just propagate to result and do not + -- try to fold, this prevents cascaded errors. if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then Set_Etype (N, Any_Type); @@ -2947,7 +3108,7 @@ package body Sem_Eval is if (Kind = N_And_Then and then Is_False (Left_Int)) or else - (Kind = N_Or_Else and then Is_True (Left_Int)) + (Kind = N_Or_Else and then Is_True (Left_Int)) then Fold_Uint (N, Left_Int, Rstat); return; @@ -2975,8 +3136,8 @@ package body Sem_Eval is -- Eval_Slice -- ---------------- - -- Slices can never be static, so the only processing required is to - -- check for non-static context if an explicit range is given. + -- Slices can never be static, so the only processing required is to check + -- for non-static context if an explicit range is given. procedure Eval_Slice (N : Node_Id) is Drange : constant Node_Id := Discrete_Range (N); @@ -2986,7 +3147,7 @@ package body Sem_Eval is Check_Non_Static_Context (High_Bound (Drange)); end if; - -- A slice of the form A (subtype), when the subtype is the index of + -- A slice of the form A (subtype), when the subtype is the index of -- the type of A, is redundant, the slice can be replaced with A, and -- this is worth a warning. @@ -3007,7 +3168,7 @@ package body Sem_Eval is Error_Msg_N ("redundant slice denotes whole array?", N); end if; - -- The following might be a useful optimization ???? + -- The following might be a useful optimization???? -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); end if; @@ -3029,7 +3190,7 @@ package body Sem_Eval is begin -- Nothing to do if error type (handles cases like default expressions - -- or generics where we have not yet fully resolved the type) + -- or generics where we have not yet fully resolved the type). if Bas = Any_Type or else Bas = Any_String then return; @@ -3047,7 +3208,7 @@ package body Sem_Eval is end if; -- Here if Etype of string literal is normal Etype (not yet possible, - -- but may be possible in future!) + -- but may be possible in future). elsif not Is_OK_Static_Expression (Type_Low_Bound (Etype (First_Index (Typ)))) @@ -3063,12 +3224,12 @@ package body Sem_Eval is return; end if; - -- Test for illegal Ada 95 cases. A string literal is illegal in - -- Ada 95 if its bounds are outside the index base type and this - -- index type is static. This can happen in only two ways. Either - -- the string literal is too long, or it is null, and the lower - -- bound is type'First. In either case it is the upper bound that - -- is out of range of the index type. + -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95 + -- if its bounds are outside the index base type and this index type is + -- static. This can happen in only two ways. Either the string literal + -- is too long, or it is null, and the lower bound is type'First. In + -- either case it is the upper bound that is out of range of the index + -- type. if Ada_Version >= Ada_95 then if Root_Type (Bas) = Standard_String @@ -3114,7 +3275,7 @@ package body Sem_Eval is -- A type conversion is potentially static if its subtype mark is for a -- static scalar subtype, and its operand expression is potentially static - -- (RM 4.9 (10)) + -- (RM 4.9(10)). procedure Eval_Type_Conversion (N : Node_Id) is Operand : constant Node_Id := Expression (N); @@ -3125,9 +3286,9 @@ package body Sem_Eval is Fold : Boolean; function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; - -- Returns true if type T is an integer type, or if it is a - -- fixed-point type to be treated as an integer (i.e. the flag - -- Conversion_OK is set on the conversion node). + -- Returns true if type T is an integer type, or if it is a fixed-point + -- type to be treated as an integer (i.e. the flag Conversion_OK is set + -- on the conversion node). function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; -- Returns true if type T is a floating-point type, or if it is a @@ -3261,10 +3422,11 @@ package body Sem_Eval is ------------------- -- Predefined unary operators are static functions (RM 4.9(20)) and thus - -- are potentially static if the operand is potentially static (RM 4.9(7)) + -- are potentially static if the operand is potentially static (RM 4.9(7)). procedure Eval_Unary_Op (N : Node_Id) is Right : constant Node_Id := Right_Opnd (N); + Otype : Entity_Id := Empty; Stat : Boolean; Fold : Boolean; @@ -3277,6 +3439,13 @@ package body Sem_Eval is return; end if; + if Etype (Right) = Universal_Integer + or else + Etype (Right) = Universal_Real + then + Otype := Find_Universal_Operator_Type (N); + end if; + -- Fold for integer case if Is_Integer_Type (Etype (N)) then @@ -3332,6 +3501,14 @@ package body Sem_Eval is Fold_Ureal (N, Result, Stat); end; end if; + + -- If the operator was resolved to a specific type, make sure that type + -- is frozen even if the expression is folded into a literal (which has + -- a universal type). + + if Present (Otype) then + Freeze_Before (N, Otype); + end if; end Eval_Unary_Op; ------------------------------- @@ -3358,8 +3535,8 @@ package body Sem_Eval is if Is_Entity_Name (N) then Ent := Entity (N); - -- An enumeration literal that was either in the source or - -- created as a result of static evaluation. + -- An enumeration literal that was either in the source or created + -- as a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then return Enumeration_Rep (Ent); @@ -3371,8 +3548,8 @@ package body Sem_Eval is return Expr_Rep_Value (Constant_Value (Ent)); end if; - -- An integer literal that was either in the source or created - -- as a result of static evaluation. + -- An integer literal that was either in the source or created as a + -- result of static evaluation. elsif Kind = N_Integer_Literal then return Intval (N); @@ -3399,11 +3576,11 @@ package body Sem_Eval is pragma Assert (Kind = N_Character_Literal); Ent := Entity (N); - -- Since Character literals of type Standard.Character don't - -- have any defining character literals built for them, they - -- do not have their Entity set, so just use their Char - -- code. Otherwise for user-defined character literals use - -- their Pos value as usual which is the same as the Rep value. + -- Since Character literals of type Standard.Character don't have any + -- defining character literals built for them, they do not have their + -- Entity set, so just use their Char code. Otherwise for user- + -- defined character literals use their Pos value as usual which is + -- the same as the Rep value. if No (Ent) then return Char_Literal_Value (N); @@ -3437,8 +3614,8 @@ package body Sem_Eval is if Is_Entity_Name (N) then Ent := Entity (N); - -- An enumeration literal that was either in the source or - -- created as a result of static evaluation. + -- An enumeration literal that was either in the source or created as + -- a result of static evaluation. if Ekind (Ent) = E_Enumeration_Literal then Val := Enumeration_Pos (Ent); @@ -3450,8 +3627,8 @@ package body Sem_Eval is Val := Expr_Value (Constant_Value (Ent)); end if; - -- An integer literal that was either in the source or created - -- as a result of static evaluation. + -- An integer literal that was either in the source or created as a + -- result of static evaluation. elsif Kind = N_Integer_Literal then Val := Intval (N); @@ -3563,8 +3740,8 @@ package body Sem_Eval is return Ureal_0; end if; - -- If we fall through, we have a node that cannot be interpreted - -- as a compile time constant. That is definitely an error. + -- If we fall through, we have a node that cannot be interpreted as a + -- compile time constant. That is definitely an error. raise Program_Error; end Expr_Value_R; @@ -3583,6 +3760,144 @@ package body Sem_Eval is end if; end Expr_Value_S; + ---------------------------------- + -- Find_Universal_Operator_Type -- + ---------------------------------- + + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is + PN : constant Node_Id := Parent (N); + Call : constant Node_Id := Original_Node (N); + Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); + + Is_Fix : constant Boolean := + Nkind (N) in N_Binary_Op + and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); + -- A mixed-mode operation in this context indicates the presence of + -- fixed-point type in the designated package. + + Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; + -- Case where N is a relational (or membership) operator (else it is an + -- arithmetic one). + + In_Membership : constant Boolean := + Nkind (PN) in N_Membership_Test + and then + Nkind (Right_Opnd (PN)) = N_Range + and then + Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) + and then + Is_Universal_Numeric_Type + (Etype (Low_Bound (Right_Opnd (PN)))) + and then + Is_Universal_Numeric_Type + (Etype (High_Bound (Right_Opnd (PN)))); + -- Case where N is part of a membership test with a universal range + + E : Entity_Id; + Pack : Entity_Id; + Typ1 : Entity_Id := Empty; + Priv_E : Entity_Id; + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; + -- Check whether one operand is a mixed-mode operation that requires the + -- presence of a fixed-point type. Given that all operands are universal + -- and have been constant-folded, retrieve the original function call. + + --------------------------- + -- Is_Mixed_Mode_Operand -- + --------------------------- + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is + Onod : constant Node_Id := Original_Node (Op); + begin + return Nkind (Onod) = N_Function_Call + and then Present (Next_Actual (First_Actual (Onod))) + and then Etype (First_Actual (Onod)) /= + Etype (Next_Actual (First_Actual (Onod))); + end Is_Mixed_Mode_Operand; + + -- Start of processing for Find_Universal_Operator_Type + + begin + if Nkind (Call) /= N_Function_Call + or else Nkind (Name (Call)) /= N_Expanded_Name + then + return Empty; + + -- There are several cases where the context does not imply the type of + -- the operands: + -- - the universal expression appears in a type conversion; + -- - the expression is a relational operator applied to universal + -- operands; + -- - the expression is a membership test with a universal operand + -- and a range with universal bounds. + + elsif Nkind (Parent (N)) = N_Type_Conversion + or else Is_Relational + or else In_Membership + then + Pack := Entity (Prefix (Name (Call))); + + -- If the prefix is a package declared elsewhere, iterate over its + -- visible entities, otherwise iterate over all declarations in the + -- designated scope. + + if Ekind (Pack) = E_Package + and then not In_Open_Scopes (Pack) + then + Priv_E := First_Private_Entity (Pack); + else + Priv_E := Empty; + end if; + + Typ1 := Empty; + E := First_Entity (Pack); + while Present (E) and then E /= Priv_E loop + if Is_Numeric_Type (E) + and then Nkind (Parent (E)) /= N_Subtype_Declaration + and then Comes_From_Source (E) + and then Is_Integer_Type (E) = Is_Int + and then + (Nkind (N) in N_Unary_Op + or else Is_Relational + or else Is_Fixed_Point_Type (E) = Is_Fix) + then + if No (Typ1) then + Typ1 := E; + + -- Before emitting an error, check for the presence of a + -- mixed-mode operation that specifies a fixed point type. + + elsif Is_Relational + and then + (Is_Mixed_Mode_Operand (Left_Opnd (N)) + or else Is_Mixed_Mode_Operand (Right_Opnd (N))) + and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) + + then + if Is_Fixed_Point_Type (E) then + Typ1 := E; + end if; + + else + -- More than one type of the proper class declared in P + + Error_Msg_N ("ambiguous operation", N); + Error_Msg_Sloc := Sloc (Typ1); + Error_Msg_N ("\possible interpretation (inherited)#", N); + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("\possible interpretation (inherited)#", N); + return Empty; + end if; + end if; + + Next_Entity (E); + end loop; + end if; + + return Typ1; + end Find_Universal_Operator_Type; + -------------------------- -- Flag_Non_Static_Expr -- -------------------------- @@ -3628,8 +3943,8 @@ package body Sem_Eval is Ent : Entity_Id; begin - -- If we are folding a named number, retain the entity in the - -- literal, for ASIS use. + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer @@ -3682,8 +3997,8 @@ package body Sem_Eval is Ent : Entity_Id; begin - -- If we are folding a named number, retain the entity in the - -- literal, for ASIS use. + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real @@ -3877,78 +4192,9 @@ package body Sem_Eval is Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is - Val : Uint; - Valr : Ureal; - - pragma Warnings (Off, Assume_Valid); - -- For now Assume_Valid is unreferenced since the current implementation - -- always returns False if N is not a compile time known value, but we - -- keep the parameter to allow for future enhancements in which we try - -- to get the information in the variable case as well. - begin - -- Universal types have no range limits, so always in range - - if Typ = Universal_Integer or else Typ = Universal_Real then - return True; - - -- Never in range if not scalar type. Don't know if this can - -- actually happen, but our spec allows it, so we must check! - - elsif not Is_Scalar_Type (Typ) then - return False; - - -- Never in range unless we have a compile time known value - - elsif not Compile_Time_Known_Value (N) then - return False; - - -- General processing with a known compile time value - - else - declare - Lo : Node_Id; - Hi : Node_Id; - LB_Known : Boolean; - UB_Known : Boolean; - - begin - Lo := Type_Low_Bound (Typ); - Hi := Type_High_Bound (Typ); - - LB_Known := Compile_Time_Known_Value (Lo); - UB_Known := Compile_Time_Known_Value (Hi); - - -- Fixed point types should be considered as such only in - -- flag Fixed_Int is set to False. - - if Is_Floating_Point_Type (Typ) - or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) - or else Int_Real - then - Valr := Expr_Value_R (N); - - if LB_Known and then Valr >= Expr_Value_R (Lo) - and then UB_Known and then Valr <= Expr_Value_R (Hi) - then - return True; - else - return False; - end if; - - else - Val := Expr_Value (N); - - if LB_Known and then Val >= Expr_Value (Lo) - and then UB_Known and then Val <= Expr_Value (Hi) - then - return True; - else - return False; - end if; - end if; - end; - end if; + return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) + = In_Range; end Is_In_Range; ------------------- @@ -4003,8 +4249,8 @@ package body Sem_Eval is -- Is_OK_Static_Subtype -- -------------------------- - -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) - -- where neither bound raises constraint error when evaluated. + -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where + -- neither bound raises constraint error when evaluated. function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is Base_T : constant Entity_Id := Base_Type (Typ); @@ -4046,8 +4292,8 @@ package body Sem_Eval is return True; else - -- Scalar_Range (Typ) might be an N_Subtype_Indication, so - -- use Get_Type_Low,High_Bound. + -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use + -- Get_Type_{Low,High}_Bound. return Is_OK_Static_Subtype (Anc_Subt) and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) @@ -4072,90 +4318,9 @@ package body Sem_Eval is Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean is - Val : Uint; - Valr : Ureal; - - pragma Warnings (Off, Assume_Valid); - -- For now Assume_Valid is unreferenced since the current implementation - -- always returns False if N is not a compile time known value, but we - -- keep the parameter to allow for future enhancements in which we try - -- to get the information in the variable case as well. - begin - -- Universal types have no range limits, so always in range - - if Typ = Universal_Integer or else Typ = Universal_Real then - return False; - - -- Never out of range if not scalar type. Don't know if this can - -- actually happen, but our spec allows it, so we must check! - - elsif not Is_Scalar_Type (Typ) then - return False; - - -- Never out of range if this is a generic type, since the bounds - -- of generic types are junk. Note that if we only checked for - -- static expressions (instead of compile time known values) below, - -- we would not need this check, because values of a generic type - -- can never be static, but they can be known at compile time. - - elsif Is_Generic_Type (Typ) then - return False; - - -- Never out of range unless we have a compile time known value - - elsif not Compile_Time_Known_Value (N) then - return False; - - else - declare - Lo : Node_Id; - Hi : Node_Id; - LB_Known : Boolean; - UB_Known : Boolean; - - begin - Lo := Type_Low_Bound (Typ); - Hi := Type_High_Bound (Typ); - - LB_Known := Compile_Time_Known_Value (Lo); - UB_Known := Compile_Time_Known_Value (Hi); - - -- Real types (note that fixed-point types are not treated - -- as being of a real type if the flag Fixed_Int is set, - -- since in that case they are regarded as integer types). - - if Is_Floating_Point_Type (Typ) - or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) - or else Int_Real - then - Valr := Expr_Value_R (N); - - if LB_Known and then Valr < Expr_Value_R (Lo) then - return True; - - elsif UB_Known and then Expr_Value_R (Hi) < Valr then - return True; - - else - return False; - end if; - - else - Val := Expr_Value (N); - - if LB_Known and then Val < Expr_Value (Lo) then - return True; - - elsif UB_Known and then Expr_Value (Hi) < Val then - return True; - - else - return False; - end if; - end if; - end; - end if; + return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) + = Out_Of_Range; end Is_Out_Of_Range; --------------------- @@ -4280,10 +4445,9 @@ package body Sem_Eval is begin -- If we have the static expression case, then this is an illegality -- in Ada 95 mode, except that in an instance, we never generate an - -- error (if the error is legitimate, it was already diagnosed in - -- the template). The expression to compute the length of a packed - -- array is attached to the array type itself, and deserves a separate - -- message. + -- error (if the error is legitimate, it was already diagnosed in the + -- template). The expression to compute the length of a packed array is + -- attached to the array type itself, and deserves a separate message. if Is_Static_Expression (N) and then not In_Instance @@ -4305,8 +4469,8 @@ package body Sem_Eval is (N, "value not in range of}", CE_Range_Check_Failed); end if; - -- Here we generate a warning for the Ada 83 case, or when we are - -- in an instance, or when we have a non-static expression case. + -- Here we generate a warning for the Ada 83 case, or when we are in an + -- instance, or when we have a non-static expression case. else Apply_Compile_Time_Constraint_Error @@ -4322,22 +4486,22 @@ package body Sem_Eval is Typ : constant Entity_Id := Etype (N); begin - -- If we want to raise CE in the condition of a raise_CE node - -- we may as well get rid of the condition + -- If we want to raise CE in the condition of a N_Raise_CE node + -- we may as well get rid of the condition. if Present (Parent (N)) and then Nkind (Parent (N)) = N_Raise_Constraint_Error then Set_Condition (Parent (N), Empty); - -- If the expression raising CE is a N_Raise_CE node, we can use - -- that one. We just preserve the type of the context + -- If the expression raising CE is a N_Raise_CE node, we can use that + -- one. We just preserve the type of the context. elsif Nkind (Exp) = N_Raise_Constraint_Error then Rewrite (N, Exp); Set_Etype (N, Typ); - -- We have to build an explicit raise_ce node + -- Else build an explcit N_Raise_CE else Rewrite (N, @@ -4475,15 +4639,15 @@ package body Sem_Eval is -- subtype, i.e. both types must be constrained or unconstrained. -- To understand the requirement for this test, see RM 4.9.1(1). - -- As is made clear in RM 3.5.4(11), type Integer, for example - -- is a constrained subtype with constraint bounds matching the - -- bounds of its corresponding unconstrained base type. In this - -- situation, Integer and Integer'Base do not statically match, - -- even though they have the same bounds. + -- As is made clear in RM 3.5.4(11), type Integer, for example is + -- a constrained subtype with constraint bounds matching the bounds + -- of its corresponding unconstrained base type. In this situation, + -- Integer and Integer'Base do not statically match, even though + -- they have the same bounds. - -- We only apply this test to types in Standard and types that - -- appear in user programs. That way, we do not have to be - -- too careful about setting Is_Constrained right for itypes. + -- We only apply this test to types in Standard and types that appear + -- in user programs. That way, we do not have to be too careful about + -- setting Is_Constrained right for Itypes. if Is_Numeric_Type (T1) and then (Is_Constrained (T1) /= Is_Constrained (T2)) @@ -4494,9 +4658,9 @@ package body Sem_Eval is then return False; - -- A generic scalar type does not statically match its base - -- type (AI-311). In this case we make sure that the formals, - -- which are first subtypes of their bases, are constrained. + -- A generic scalar type does not statically match its base type + -- (AI-311). In this case we make sure that the formals, which are + -- first subtypes of their bases, are constrained. elsif Is_Generic_Type (T1) and then Is_Generic_Type (T2) @@ -4505,8 +4669,8 @@ package body Sem_Eval is return False; end if; - -- If there was an error in either range, then just assume - -- the types statically match to avoid further junk errors + -- If there was an error in either range, then just assume the types + -- statically match to avoid further junk errors. if Error_Posted (Scalar_Range (T1)) or else @@ -4537,8 +4701,8 @@ package body Sem_Eval is then return False; - -- If either type has constraint error bounds, then say - -- that they match to avoid junk cascaded errors here. + -- If either type has constraint error bounds, then say that + -- they match to avoid junk cascaded errors here. elsif not Is_OK_Static_Subtype (T1) or else not Is_OK_Static_Subtype (T2) @@ -4648,11 +4812,11 @@ package body Sem_Eval is return True; - -- A definite type does not match an indefinite or classwide type + -- A definite type does not match an indefinite or classwide type. -- However, a generic type with unknown discriminants may be -- instantiated with a type with no discriminants, and conformance - -- checking on an inherited operation may compare the actual with - -- the subtype that renames it in the instance. + -- checking on an inherited operation may compare the actual with the + -- subtype that renames it in the instance. elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) @@ -4664,16 +4828,15 @@ package body Sem_Eval is elsif Is_Array_Type (T1) then - -- If either subtype is unconstrained then both must be, - -- and if both are unconstrained then no further checking - -- is needed. + -- If either subtype is unconstrained then both must be, and if both + -- are unconstrained then no further checking is neede. if not Is_Constrained (T1) or else not Is_Constrained (T2) then return not (Is_Constrained (T1) or else Is_Constrained (T2)); end if; - -- Both subtypes are constrained, so check that the index - -- subtypes statically match. + -- Both subtypes are constrained, so check that the index subtypes + -- statically match. declare Index1 : Node_Id := First_Index (T1); @@ -4698,8 +4861,8 @@ package body Sem_Eval is if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then return False; - elsif Ekind (T1) = E_Access_Subprogram_Type - or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type + elsif Ekind_In (T1, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) then return Subtype_Conformant @@ -4824,8 +4987,8 @@ package body Sem_Eval is Set_Etype (N, Any_Type); return; - -- If left operand raises constraint error, then replace node N with - -- the raise constraint error node, and we are obviously not foldable. + -- If left operand raises constraint error, then replace node N with the + -- Raise_Constraint_Error node, and we are obviously not foldable. -- Is_Static_Expression is set from the two operands in the normal way, -- and we check the right operand if it is in a non-static context. @@ -4838,9 +5001,9 @@ package body Sem_Eval is Set_Is_Static_Expression (N, Rstat); return; - -- Similar processing for the case of the right operand. Note that - -- we don't use this routine for the short-circuit case, so we do - -- not have to worry about that special case here. + -- Similar processing for the case of the right operand. Note that we + -- don't use this routine for the short-circuit case, so we do not have + -- to worry about that special case here. elsif Raises_Constraint_Error (Op2) then if not Rstat then @@ -4860,7 +5023,7 @@ package body Sem_Eval is return; -- If result is not static, then check non-static contexts on operands - -- since one of them may be static and the other one may not be static + -- since one of them may be static and the other one may not be static. elsif not Rstat then Check_Non_Static_Context (Op1); @@ -4869,8 +5032,8 @@ package body Sem_Eval is and then Compile_Time_Known_Value (Op2); return; - -- Else result is static and foldable. Both operands are static, - -- and neither raises constraint error, so we can definitely fold. + -- Else result is static and foldable. Both operands are static, and + -- neither raises constraint error, so we can definitely fold. else Set_Is_Static_Expression (N); @@ -4880,6 +5043,125 @@ package body Sem_Eval is end if; end Test_Expression_Is_Foldable; + ------------------- + -- Test_In_Range -- + ------------------- + + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership + is + Val : Uint; + Valr : Ureal; + + pragma Warnings (Off, Assume_Valid); + -- For now Assume_Valid is unreferenced since the current implementation + -- always returns Unknown if N is not a compile time known value, but we + -- keep the parameter to allow for future enhancements in which we try + -- to get the information in the variable case as well. + + begin + -- Universal types have no range limits, so always in range + + if Typ = Universal_Integer or else Typ = Universal_Real then + return In_Range; + + -- Never known if not scalar type. Don't know if this can actually + -- happen, but our spec allows it, so we must check! + + elsif not Is_Scalar_Type (Typ) then + return Unknown; + + -- Never known if this is a generic type, since the bounds of generic + -- types are junk. Note that if we only checked for static expressions + -- (instead of compile time known values) below, we would not need this + -- check, because values of a generic type can never be static, but they + -- can be known at compile time. + + elsif Is_Generic_Type (Typ) then + return Unknown; + + -- Never known unless we have a compile time known value + + elsif not Compile_Time_Known_Value (N) then + return Unknown; + + -- General processing with a known compile time value + + else + declare + Lo : Node_Id; + Hi : Node_Id; + + LB_Known : Boolean; + HB_Known : Boolean; + + begin + Lo := Type_Low_Bound (Typ); + Hi := Type_High_Bound (Typ); + + LB_Known := Compile_Time_Known_Value (Lo); + HB_Known := Compile_Time_Known_Value (Hi); + + -- Fixed point types should be considered as such only if flag + -- Fixed_Int is set to False. + + if Is_Floating_Point_Type (Typ) + or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) + or else Int_Real + then + Valr := Expr_Value_R (N); + + if LB_Known and HB_Known then + if Valr >= Expr_Value_R (Lo) + and then + Valr <= Expr_Value_R (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Valr < Expr_Value_R (Lo)) + or else + (HB_Known and then Valr > Expr_Value_R (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + + else + Val := Expr_Value (N); + + if LB_Known and HB_Known then + if Val >= Expr_Value (Lo) + and then + Val <= Expr_Value (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Val < Expr_Value (Lo)) + or else + (HB_Known and then Val > Expr_Value (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + end if; + end; + end if; + end Test_In_Range; + -------------- -- To_Bits -- -------------- @@ -4901,8 +5183,8 @@ package body Sem_Eval is E : Entity_Id; procedure Why_Not_Static_List (L : List_Id); - -- A version that can be called on a list of expressions. Finds - -- all non-static violations in any element of the list. + -- A version that can be called on a list of expressions. Finds all + -- non-static violations in any element of the list. ------------------------- -- Why_Not_Static_List -- @@ -4924,8 +5206,8 @@ package body Sem_Eval is -- Start of processing for Why_Not_Static begin - -- If in ACATS mode (debug flag 2), then suppress all these - -- messages, this avoids massive updates to the ACATS base line. + -- If in ACATS mode (debug flag 2), then suppress all these messages, + -- this avoids massive updates to the ACATS base line. if Debug_Flag_2 then return; @@ -5049,8 +5331,8 @@ package body Sem_Eval is return; - -- Special case generic types, since again this is a common - -- source of confusion. + -- Special case generic types, since again this is a common source + -- of confusion. elsif Is_Generic_Actual_Type (E) or else diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 565ce675873..078ac375c35 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -282,6 +282,7 @@ package Sem_Eval is procedure Eval_Allocator (N : Node_Id); procedure Eval_Arithmetic_Op (N : Node_Id); procedure Eval_Call (N : Node_Id); + procedure Eval_Case_Expression (N : Node_Id); procedure Eval_Character_Literal (N : Node_Id); procedure Eval_Concatenation (N : Node_Id); procedure Eval_Conditional_Expression (N : Node_Id); diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 42136b13ee8..20a1614fb06 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -53,8 +53,8 @@ package body Sem_Intr is -- returns type String. procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id); - -- Check that operator is one of the binary arithmetic operators, and - -- that the types involved have the same size. + -- Check that operator is one of the binary arithmetic operators, and that + -- the types involved both have underlying integer types. procedure Check_Shift (E : Entity_Id; N : Node_Id); -- Check intrinsic shift subprogram, the two arguments are the same @@ -73,9 +73,7 @@ package body Sem_Intr is procedure Check_Exception_Function (E : Entity_Id; N : Node_Id) is begin - if Ekind (E) /= E_Function - and then Ekind (E) /= E_Generic_Function - then + if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic exception subprogram must be a function", E, N); @@ -200,11 +198,24 @@ package body Sem_Intr is T2 := Etype (Next_Formal (First_Formal (E))); end if; - if Root_Type (T1) /= Root_Type (T2) - or else Root_Type (T1) /= Root_Type (Ret) + if Root_Type (T1) = Root_Type (T2) + or else Root_Type (T1) = Root_Type (Ret) + then + -- Same types, predefined operator will apply + + null; + + elsif Is_Integer_Type (Underlying_Type (T1)) + and then Is_Integer_Type (Underlying_Type (T2)) + and then Is_Integer_Type (Underlying_Type (Ret)) then + -- Expansion will introduce conversions if sizes are not equal + + null; + + else Errint - ("types of intrinsic operator must have the same size", E, N); + ("types of intrinsic operator operands do not match", E, N); end if; -- Comparison operators @@ -274,7 +285,7 @@ package body Sem_Intr is return; end if; - if not Is_Numeric_Type (T1) then + if not Is_Numeric_Type (Underlying_Type (T1)) then Errint ("intrinsic operator can only apply to numeric types", E, N); end if; end Check_Intrinsic_Operator; @@ -374,9 +385,7 @@ package body Sem_Intr is Ptyp2 : Node_Id; begin - if Ekind (E) /= E_Function - and then Ekind (E) /= E_Generic_Function - then + if not Ekind_In (E, E_Function, E_Generic_Function) then Errint ("intrinsic shift subprogram must be a function", E, N); return; end if; diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb index 5f18176b8c2..1954b3deb74 100644 --- a/gcc/ada/sem_mech.adb +++ b/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, 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- -- @@ -92,8 +92,7 @@ package body Sem_Mech is return; elsif Chars (Mech_Name) = Name_Copy then - Error_Msg_N - ("bad mechanism name, Value assumed", Mech_Name); + Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); Set_Mechanism (Ent, By_Copy); else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0e8157a875b..e5afd0cebb8 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -46,6 +46,7 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; +with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -1393,9 +1394,12 @@ package body Sem_Prag is Pragma_Misplaced; end if; - -- Record whether pragma is enabled + -- Record if pragma is enabled - Set_Pragma_Enabled (N, Check_Enabled (Pname)); + if Check_Enabled (Pname) then + Set_Pragma_Enabled (N); + Set_SCO_Pragma_Enabled (Loc); + end if; -- If we are within an inlined body, the legality of the pragma -- has been checked already. @@ -1842,7 +1846,8 @@ package body Sem_Prag is Proc := Entity (Name); if Ekind (Proc) /= E_Procedure - or else Present (First_Formal (Proc)) then + or else Present (First_Formal (Proc)) + then Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg); end if; @@ -2341,12 +2346,176 @@ package body Sem_Prag is Cname : Name_Id; Comp_Unit : Unit_Number_Type; + procedure Diagnose_Multiple_Pragmas (S : Entity_Id); + -- Called if we have more than one Export/Import/Convention pragma. + -- This is generally illegal, but we have a special case of allowing + -- Import and Interface to coexist if they specify the convention in + -- a consistent manner. We are allowed to do this, since Interface is + -- an implementation defined pragma, and we choose to do it since we + -- know Rational allows this combination. S is the entity id of the + -- subprogram in question. This procedure also sets the special flag + -- Import_Interface_Present in both pragmas in the case where we do + -- have matching Import and Interface pragmas. + procedure Set_Convention_From_Pragma (E : Entity_Id); -- Set convention in entity E, and also flag that the entity has a -- convention pragma. If entity is for a private or incomplete type, -- also set convention and flag on underlying type. This procedure -- also deals with the special case of C_Pass_By_Copy convention. + ------------------------------- + -- Diagnose_Multiple_Pragmas -- + ------------------------------- + + procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is + Pdec : constant Node_Id := Declaration_Node (S); + Decl : Node_Id; + Err : Boolean; + + function Same_Convention (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a first argument that is an identifier with a + -- Chars field corresponding to the Convention_Id C. + + function Same_Name (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a second argument that is an identifier with a + -- Chars field that matches the Chars of the current subprogram. + + --------------------- + -- Same_Convention -- + --------------------- + + function Same_Convention (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + + begin + if Present (Arg1) then + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Nkind (Arg) = N_Identifier + and then Is_Convention_Name (Chars (Arg)) + and then Get_Convention_Id (Chars (Arg)) = C + then + return True; + end if; + end; + end if; + + return False; + end Same_Convention; + + --------------- + -- Same_Name -- + --------------- + + function Same_Name (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + Arg2 : Node_Id; + + begin + if No (Arg1) then + return False; + end if; + + Arg2 := Next (Arg1); + + if No (Arg2) then + return False; + end if; + + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg2); + begin + if Nkind (Arg) = N_Identifier + and then Chars (Arg) = Chars (S) + then + return True; + end if; + end; + + return False; + end Same_Name; + + -- Start of processing for Diagnose_Multiple_Pragmas + + begin + Err := True; + + -- Definitely give message if we have Convention/Export here + + if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then + null; + + -- If we have an Import or Export, scan back from pragma to + -- find any previous pragma applying to the same procedure. + -- The scan will be terminated by the start of the list, or + -- hitting the subprogram declaration. This won't allow one + -- pragma to appear in the public part and one in the private + -- part, but that seems very unlikely in practice. + + else + Decl := Prev (N); + while Present (Decl) and then Decl /= Pdec loop + + -- Look for pragma with same name as us + + if Nkind (Decl) = N_Pragma + and then Same_Name (Decl) + then + -- Give error if same as our pragma or Export/Convention + + if Pragma_Name (Decl) = Name_Export + or else + Pragma_Name (Decl) = Name_Convention + or else + Pragma_Name (Decl) = Pragma_Name (N) + then + exit; + + -- Case of Import/Interface or the other way round + + elsif Pragma_Name (Decl) = Name_Interface + or else + Pragma_Name (Decl) = Name_Import + then + -- Here we know that we have Import and Interface. It + -- doesn't matter which way round they are. See if + -- they specify the same convention. If so, all OK, + -- and set special flags to stop other messages + + if Same_Convention (Decl) then + Set_Import_Interface_Present (N); + Set_Import_Interface_Present (Decl); + Err := False; + + -- If different conventions, special message + + else + Error_Msg_Sloc := Sloc (Decl); + Error_Pragma_Arg + ("convention differs from that given#", Arg1); + return; + end if; + end if; + end if; + + Next (Decl); + end loop; + end if; + + -- Give message if needed if we fall through those tests + + if Err then + Error_Pragma_Arg + ("at most one Convention/Export/Import pragma is allowed", + Arg2); + end if; + end Diagnose_Multiple_Pragmas; + -------------------------------- -- Set_Convention_From_Pragma -- -------------------------------- @@ -2512,10 +2681,7 @@ package body Sem_Prag is -- Check that we are not applying this to a named constant - if Ekind (E) = E_Named_Integer - or else - Ekind (E) = E_Named_Real - then + if Ekind_In (E, E_Named_Integer, E_Named_Real) then Error_Msg_Name_1 := Pname; Error_Msg_N ("cannot apply pragma% to named constant!", @@ -2543,8 +2709,7 @@ package body Sem_Prag is end if; if Has_Convention_Pragma (E) then - Error_Pragma_Arg - ("at most one Convention/Export/Import pragma is allowed", Arg2); + Diagnose_Multiple_Pragmas (E); elsif Convention (E) = Convention_Protected or else Ekind (Scope (E)) = E_Protected_Type @@ -2752,9 +2917,7 @@ package body Sem_Prag is Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Arg_Internal); end if; @@ -3106,7 +3269,7 @@ package body Sem_Prag is Prag_Id = Pragma_Import_Valued_Procedure then if not Is_Imported (Ent) then - Error_Pragma -- CODEFIX??? + Error_Pragma ("pragma Import or Interface must precede pragma%"); end if; @@ -3364,10 +3527,8 @@ package body Sem_Prag is Kill_Size_Check_Code (Def_Id); Note_Possible_Modification (Expression (Arg2), Sure => False); - if Ekind (Def_Id) = E_Variable - or else - Ekind (Def_Id) = E_Constant - then + if Ekind_In (Def_Id, E_Variable, E_Constant) then + -- We do not permit Import to apply to a renaming declaration if Present (Renamed_Object (Def_Id)) then @@ -3795,9 +3956,7 @@ package body Sem_Prag is -- entity (if declared in the same unit) is inlined. if Is_Subprogram (Subp) then - while Present (Alias (Inner_Subp)) loop - Inner_Subp := Alias (Inner_Subp); - end loop; + Inner_Subp := Ultimate_Alias (Inner_Subp); if In_Same_Source_Unit (Subp, Inner_Subp) then Set_Inline_Flags (Inner_Subp); @@ -4575,8 +4734,7 @@ package body Sem_Prag is end if; if Warn_On_Export_Import and then Is_Type (E) then - Error_Msg_NE - ("exporting a type has no effect?", Arg, E); + Error_Msg_NE ("exporting a type has no effect?", Arg, E); end if; if Warn_On_Export_Import and Inside_A_Generic then @@ -4676,8 +4834,19 @@ package body Sem_Prag is -- Error message if already imported or exported if Is_Exported (E) or else Is_Imported (E) then + + -- Error if being set Exported twice + if Is_Exported (E) then Error_Msg_NE ("entity& was previously exported", N, E); + + -- OK if Import/Interface case + + elsif Import_Interface_Present (N) then + goto OK; + + -- Error if being set Imported twice + else Error_Msg_NE ("entity& was previously imported", N, E); end if; @@ -4706,6 +4875,8 @@ package body Sem_Prag is Set_Is_Statically_Allocated (E); end if; end if; + + <<OK>> null; end Set_Imported; ------------------------- @@ -5086,8 +5257,9 @@ package body Sem_Prag is -- said this was a configuration pragma, but we did not check and -- are hesitant to add the check now. - -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 - -- or Ada 95, so we must check if we are in Ada 2005 mode. + -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 + -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 + -- or Ada 2012 mode. if Ada_Version >= Ada_05 then Check_Valid_Configuration_Pragma; @@ -5176,6 +5348,33 @@ package body Sem_Prag is end if; end; + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- + + -- pragma Ada_12; + -- pragma Ada_2012; + + -- Note: these pragma also have some specific processing in Par.Prag + -- because we want to set the Ada 2012 version mode during parsing. + + when Pragma_Ada_12 | Pragma_Ada_2012 => + GNAT_Pragma; + Check_Arg_Count (0); + + -- For Ada_2012 we unconditionally enforce the documented + -- configuration pragma placement, since we do not want to + -- tolerate mixed modes in a unit involving Ada 2012. That would + -- cause real difficulties for those cases where there are + -- incompatibilities between Ada 95 and Ada 2005/Ada 2012. + + Check_Valid_Configuration_Pragma; + + -- Now set Ada 2012 mode + + Ada_Version := Ada_12; + Ada_Version_Explicit := Ada_12; + ---------------------- -- All_Calls_Remote -- ---------------------- @@ -5776,8 +5975,12 @@ package body Sem_Prag is -- is to deal with pragma Assert rewritten as a Check pragma. Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); - Set_Pragma_Enabled (N, Check_On); - Set_Pragma_Enabled (Original_Node (N), Check_On); + + if Check_On then + Set_Pragma_Enabled (N); + Set_Pragma_Enabled (Original_Node (N)); + Set_SCO_Pragma_Enabled (Loc); + end if; -- If expansion is active and the check is not enabled then we -- rewrite the Check as: @@ -7276,8 +7479,11 @@ package body Sem_Prag is if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + else Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; end if; -------------- @@ -9123,9 +9329,7 @@ package body Sem_Prag is while Present (E) and then Scope (E) = Current_Scope loop - if Ekind (E) = E_Procedure - or else Ekind (E) = E_Generic_Procedure - then + if Ekind_In (E, E_Procedure, E_Generic_Procedure) then Set_No_Return (E); -- Set flag on any alias as well @@ -9907,7 +10111,7 @@ package body Sem_Prag is -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always - -- set to Ada_05 in a predefined unit), we need to know the + -- set to Ada_12 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. if Ada_Version_Explicit >= Ada_05 then @@ -10283,9 +10487,7 @@ package body Sem_Prag is Def_Id := Entity (Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Internal); end if; @@ -10409,7 +10611,7 @@ package body Sem_Prag is -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always - -- set to Ada_05 in a predefined unit), we need to know the + -- set to Ada_12 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. if Ada_Version_Explicit >= Ada_05 then @@ -10451,9 +10653,9 @@ package body Sem_Prag is loop Def_Id := Get_Base_Subprogram (E); - if Ekind (Def_Id) /= E_Function - and then Ekind (Def_Id) /= E_Generic_Function - and then Ekind (Def_Id) /= E_Operator + if not Ekind_In (Def_Id, E_Function, + E_Generic_Function, + E_Operator) then Error_Pragma_Arg ("pragma% requires a function name", Arg1); @@ -10473,8 +10675,9 @@ package body Sem_Prag is if not Effective and then Warn_On_Redundant_Constructs then - Error_Msg_NE ("pragma Pure_Function on& is redundant?", - N, Entity (E_Id)); + Error_Msg_NE + ("pragma Pure_Function on& is redundant?", + N, Entity (E_Id)); end if; end if; end Pure_Function; @@ -10647,10 +10850,8 @@ package body Sem_Prag is Set_Ravenscar_Profile (N); if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("pragma Ravenscar is an obsolescent feature?", N); - Error_Msg_N - ("|use pragma Profile (Ravenscar) instead", N); + Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N); + Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N); end if; ------------------------- @@ -10669,8 +10870,7 @@ package body Sem_Prag is if Warn_On_Obsolescent_Feature then Error_Msg_N ("pragma Restricted_Run_Time is an obsolescent feature?", N); - Error_Msg_N - ("|use pragma Profile (Restricted) instead", N); + Error_Msg_N ("|use pragma Profile (Restricted) instead", N); end if; ------------------ @@ -11153,7 +11353,11 @@ package body Sem_Prag is elsif Nkind (A) = N_Identifier then if Chars (A) = Name_All_Checks then - Set_Default_Style_Check_Options; + if GNAT_Mode then + Set_GNAT_Style_Check_Options; + else + Set_Default_Style_Check_Options; + end if; elsif Chars (A) = Name_On then Style_Check := True; @@ -12080,7 +12284,7 @@ package body Sem_Prag is elsif not Is_Static_String_Expression (Arg1) then Error_Pragma_Arg ("argument of pragma% must be On/Off or " & - "static string expression", Arg2); + "static string expression", Arg1); -- One argument string expression case @@ -12300,6 +12504,11 @@ package body Sem_Prag is raise Program_Error; end case; + -- AI05-0144: detect dangerous order dependence. Disabled for now, + -- until AI is formally approved. + + -- Check_Order_Dependence; + exception when Pragma_Exit => null; end Analyze_Pragma; @@ -12474,6 +12683,8 @@ package body Sem_Prag is Pragma_Ada_95 => -1, Pragma_Ada_05 => -1, Pragma_Ada_2005 => -1, + Pragma_Ada_12 => -1, + Pragma_Ada_2012 => -1, Pragma_All_Calls_Remote => -1, Pragma_Annotate => -1, Pragma_Assert => -1, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0e234925bac..92ae30f4e55 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -130,10 +130,14 @@ package body Sem_Res is -- declaration, and not an (anonymous) allocator type. function Is_Predefined_Op (Nam : Entity_Id) return Boolean; - -- Utility to check whether the name in the call is a predefined - -- operator, in which case the call is made into an operator node. - -- An instance of an intrinsic conversion operation may be given - -- an operator name, but is not treated like an operator. + -- Utility to check whether the entity for an operator is a predefined + -- operator, in which case the expression is left as an operator in the + -- tree (else it is rewritten into a call). An instance of an intrinsic + -- conversion operation may be given an operator name, but is not treated + -- like an operator. Note that an operator that is an imported back-end + -- builtin has convention Intrinsic, but is expected to be rewritten into + -- a call, so such an operator is not treated as predefined by this + -- predicate. procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); -- If a default expression in entry call N depends on the discriminants @@ -160,12 +164,14 @@ package body Sem_Res is procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); @@ -211,9 +217,13 @@ package body Sem_Res is procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); -- A call to a user-defined intrinsic operator is rewritten as a call -- to the corresponding predefined operator, with suitable conversions. + -- Note that this applies only for intrinsic operators that denote + -- predefined operators, not operators that are intrinsic imports of + -- back-end builtins. procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); - -- Ditto, for unary operators (only arithmetic ones) + -- Ditto, for unary operators (arithmetic ones and "not" on signed + -- integer types for VMS). procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, @@ -276,16 +286,13 @@ package body Sem_Res is -- First the ones in Standard - Error_Msg_N - ("\\possible interpretation: Character!", C); - Error_Msg_N - ("\\possible interpretation: Wide_Character!", C); + Error_Msg_N ("\\possible interpretation: Character!", C); + Error_Msg_N ("\\possible interpretation: Wide_Character!", C); -- Include Wide_Wide_Character in Ada 2005 mode if Ada_Version >= Ada_05 then - Error_Msg_N - ("\\possible interpretation: Wide_Wide_Character!", C); + Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C); end if; -- Now any other types that match @@ -632,9 +639,10 @@ package body Sem_Res is procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is begin if Is_Invisible_Operator (N, T) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("operator for} is not directly visible!", N, First_Subtype (T)); - Error_Msg_N ("use clause would make operation legal!", N); + Error_Msg_N -- CODEFIX + ("use clause would make operation legal!", N); end if; end Check_For_Visible_Operator; @@ -898,10 +906,12 @@ package body Sem_Res is Expr := Original_Node (Expression (Parent (Comp))); -- Return True if the expression is a call to a function - -- (including an attribute function such as Image) with - -- a result that requires a transient scope. + -- (including an attribute function such as Image, or a + -- user-defined operator) with a result that requires a + -- transient scope. if (Nkind (Expr) = N_Function_Call + or else Nkind (Expr) in N_Op or else (Nkind (Expr) = N_Attribute_Reference and then Present (Expressions (Expr)))) and then Requires_Transient_Scope (Etype (Expr)) @@ -1034,7 +1044,7 @@ package body Sem_Res is if (Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) and then (Ekind (Entity (N)) /= E_Enumeration_Literal - or else Is_Overloaded (N))) + or else Is_Overloaded (N))) -- Rewrite as call if it is an explicit dereference of an expression of -- a subprogram access type, and the subprogram type is not that of a @@ -1050,11 +1060,10 @@ package body Sem_Res is or else (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function - or else - ((Ekind (Entity (Selector_Name (N))) = E_Entry - or else - Ekind (Entity (Selector_Name (N))) = E_Procedure) - and then Is_Overloaded (Selector_Name (N))))) + or else + (Ekind_In (Entity (Selector_Name (N)), E_Entry, + E_Procedure) + and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. -- Apply the rewriting only once. @@ -1102,11 +1111,21 @@ package body Sem_Res is function Is_Predefined_Op (Nam : Entity_Id) return Boolean is begin - return Is_Intrinsic_Subprogram (Nam) - and then not Is_Generic_Instance (Nam) + -- Predefined operators are intrinsic subprograms + + if not Is_Intrinsic_Subprogram (Nam) then + return False; + end if; + + -- A call to a back-end builtin is never a predefined operator + + if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then + return False; + end if; + + return not Is_Generic_Instance (Nam) and then Chars (Nam) in Any_Operator_Name - and then (No (Alias (Nam)) - or else Is_Predefined_Op (Alias (Nam))); + and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam))); end Is_Predefined_Op; ----------------------------- @@ -1133,7 +1152,7 @@ package body Sem_Res is function Operand_Type_In_Scope (S : Entity_Id) return Boolean; -- If the operand is not universal, and the operator is given by a - -- expanded name, verify that the operand has an interpretation with + -- expanded name, verify that the operand has an interpretation with -- a type defined in the given scope of the operator. function Type_In_P (Test : Kind_Test) return Entity_Id; @@ -1274,16 +1293,15 @@ package body Sem_Res is -- you courtesy of b33302a. The type itself must be frozen, so we must -- find the type of the proper class in the given scope. - -- A final wrinkle is the multiplication operator for fixed point - -- types, which is defined in Standard only, and not in the scope of - -- the fixed_point type itself. + -- A final wrinkle is the multiplication operator for fixed point types, + -- which is defined in Standard only, and not in the scope of the + -- fixed_point type itself. if Nkind (Name (N)) = N_Expanded_Name then Pack := Entity (Prefix (Name (N))); - -- If the entity being called is defined in the given package, - -- it is a renaming of a predefined operator, and known to be - -- legal. + -- If the entity being called is defined in the given package, it is + -- a renaming of a predefined operator, and known to be legal. if Scope (Entity (Name (N))) = Pack and then Pack /= Standard_Standard @@ -1297,8 +1315,7 @@ package body Sem_Res is elsif In_Instance then null; - elsif (Op_Name = Name_Op_Multiply - or else Op_Name = Name_Op_Divide) + elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) then @@ -1306,8 +1323,8 @@ package body Sem_Res is Error := True; end if; - -- Ada 2005, AI-420: Predefined equality on Universal_Access - -- is available. + -- Ada 2005, AI-420: Predefined equality on Universal_Access is + -- available. elsif Ada_Version >= Ada_05 and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) @@ -1338,7 +1355,7 @@ package body Sem_Res is if Pack /= Standard_Standard then if Opnd_Type = Universal_Integer then - Orig_Type := Type_In_P (Is_Integer_Type'Access); + Orig_Type := Type_In_P (Is_Integer_Type'Access); elsif Opnd_Type = Universal_Real then Orig_Type := Type_In_P (Is_Real_Type'Access); @@ -1347,7 +1364,7 @@ package body Sem_Res is Orig_Type := Type_In_P (Is_String_Type'Access); elsif Opnd_Type = Any_Access then - Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); + Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); elsif Opnd_Type = Any_Composite then Orig_Type := Type_In_P (Is_Composite_Type'Access); @@ -1407,6 +1424,41 @@ package body Sem_Res is ("& not declared in&", N, Selector_Name (Name (N))); Set_Etype (N, Any_Type); return; + + -- Detect a mismatch between the context type and the result type + -- in the named package, which is otherwise not detected if the + -- operands are universal. Check is only needed if source entity is + -- an operator, not a function that renames an operator. + + elsif Nkind (Parent (N)) /= N_Type_Conversion + and then Ekind (Entity (Name (N))) = E_Operator + and then Is_Numeric_Type (Typ) + and then not Is_Universal_Numeric_Type (Typ) + and then Scope (Base_Type (Typ)) /= Pack + and then not In_Instance + then + if Is_Fixed_Point_Type (Typ) + and then (Op_Name = Name_Op_Multiply + or else + Op_Name = Name_Op_Divide) + then + -- Already checked above + + null; + + -- Operator may be defined in an extension of System + + elsif Present (System_Aux_Id) + and then Scope (Opnd_Type) = System_Aux_Id + then + null; + + else + -- Could we use Wrong_Type here??? (this would require setting + -- Etype (N) to the actual type found where Typ was expected). + + Error_Msg_NE ("expect }", N, Typ); + end if; end if; end if; @@ -1468,14 +1520,6 @@ package body Sem_Res is else Resolve (N, Typ); end if; - - -- For predefined operators on literals, the operation freezes - -- their type. - - if Present (Orig_Type) then - Set_Etype (Act1, Orig_Type); - Freeze_Expression (Act1); - end if; end Make_Call_Into_Operator; ------------------- @@ -1842,6 +1886,7 @@ package body Sem_Res is -- Check that Typ is a remote access-to-subprogram type if Is_Remote_Access_To_Subprogram_Type (Typ) then + -- Prefix (N) must statically denote a remote subprogram -- declared in a package specification. @@ -2076,7 +2121,7 @@ package body Sem_Res is end if; if Nkind_In - (N, N_Procedure_Call_Statement, N_Function_Call) + (N, N_Procedure_Call_Statement, N_Function_Call) and then Present (Parameter_Associations (N)) then Report_Ambiguous_Argument; @@ -2121,7 +2166,7 @@ package body Sem_Res is -- If this is an indirect call, use the subprogram_type -- in the message, to have a meaningful location. - -- Indicate as well if this is an inherited operation, + -- Also indicate if this is an inherited operation, -- created by a type declaration. elsif Nkind (N) = N_Function_Call @@ -2178,6 +2223,9 @@ package body Sem_Res is Set_Entity (N, Seen); Generate_Reference (Seen, N); + elsif Nkind (N) = N_Case_Expression then + Set_Etype (N, Expr_Type); + elsif Nkind (N) = N_Character_Literal then Set_Etype (N, Expr_Type); @@ -2202,7 +2250,7 @@ package body Sem_Res is null; -- For procedure or function calls, set the type of the name, - -- and also the entity pointer for the prefix + -- and also the entity pointer for the prefix. elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) and then (Is_Entity_Name (Name (N)) @@ -2238,9 +2286,9 @@ package body Sem_Res is end if; -- At this stage Found indicates whether or not an acceptable - -- interpretation exists. If not, then we have an error, except - -- that if the context is Any_Type as a result of some other error, - -- then we suppress the error report. + -- interpretation exists. If not, then we have an error, except that if + -- the context is Any_Type as a result of some other error, then we + -- suppress the error report. if not Found then if Typ /= Any_Type then @@ -2533,6 +2581,9 @@ package body Sem_Res is when N_Attribute_Reference => Resolve_Attribute (N, Ctx_Type); + when N_Case_Expression + => Resolve_Case_Expression (N, Ctx_Type); + when N_Character_Literal => Resolve_Character_Literal (N, Ctx_Type); @@ -2542,12 +2593,15 @@ package body Sem_Res is when N_Expanded_Name => Resolve_Entity_Name (N, Ctx_Type); - when N_Extension_Aggregate - => Resolve_Extension_Aggregate (N, Ctx_Type); - when N_Explicit_Dereference => Resolve_Explicit_Dereference (N, Ctx_Type); + when N_Expression_With_Actions + => Resolve_Expression_With_Actions (N, Ctx_Type); + + when N_Extension_Aggregate + => Resolve_Extension_Aggregate (N, Ctx_Type); + when N_Function_Call => Resolve_Call (N, Ctx_Type); @@ -2628,7 +2682,6 @@ package body Sem_Res is when N_Unchecked_Type_Conversion => Resolve_Unchecked_Type_Conversion (N, Ctx_Type); - end case; -- If the subexpression was replaced by a non-subexpression, then @@ -3423,6 +3476,13 @@ package body Sem_Res is A_Typ := Etype (A); F_Typ := Etype (F); + -- Save actual for subsequent check on order dependence, + -- and indicate whether actual is modifiable. For AI05-0144 + + -- Save_Actual (A, + -- Ekind (F) /= E_In_Parameter or else Is_Access_Type (F_Typ)); + -- Why is this code commented out ??? + -- For mode IN, if actual is an entity, and the type of the formal -- has warnings suppressed, then we reset Never_Set_In_Source for -- the calling entity. The reason for this is to catch cases like @@ -3534,9 +3594,7 @@ package body Sem_Res is -- might not be done in the In Out case since Gigi does not do -- any analysis. More thought required about this ??? - if Ekind (F) = E_In_Parameter - or else Ekind (F) = E_In_Out_Parameter - then + if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then if Is_Scalar_Type (Etype (A)) then Apply_Scalar_Range_Check (A, F_Typ); @@ -3582,9 +3640,7 @@ package body Sem_Res is end if; end if; - if Ekind (F) = E_Out_Parameter - or else Ekind (F) = E_In_Out_Parameter - then + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then if Nkind (A) = N_Type_Conversion then if Is_Scalar_Type (A_Typ) then Apply_Scalar_Range_Check @@ -4612,7 +4668,7 @@ package body Sem_Res is -- If the context is Universal_Fixed and the operands are also -- universal fixed, this is an error, unless there is only one - -- applicable fixed_point type (usually duration). + -- applicable fixed_point type (usually Duration). if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then T := Unique_Fixed_Point_Type (N); @@ -5070,10 +5126,15 @@ package body Sem_Res is Expressions => Parameter_Associations (N)); end if; + -- Preserve the parenthesis count of the node + + Set_Paren_Count (Index_Node, Paren_Count (N)); + -- Since we are correcting a node classification error made -- by the parser, we call Replace rather than Rewrite. Replace (N, Index_Node); + Set_Etype (Prefix (N), Ret_Type); Set_Etype (N, Typ); Resolve_Indexed_Component (N, Typ); @@ -5382,9 +5443,7 @@ package body Sem_Res is F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop - if (Ekind (F) = E_Out_Parameter - or else - Ekind (F) = E_In_Out_Parameter) + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) @@ -5446,9 +5505,14 @@ package body Sem_Res is Check_Potentially_Blocking_Operation (N); end if; - -- Issue an error for a call to an eliminated subprogram + -- Issue an error for a call to an eliminated subprogram. We skip this + -- in a spec expression, e.g. a call in a default parameter value, since + -- we are not really doing a call at this time. That's important because + -- the spec expression may itself belong to an eliminated subprogram. - Check_For_Eliminated_Subprogram (Subp, Nam); + if not In_Spec_Expression then + Check_For_Eliminated_Subprogram (Subp, Nam); + end if; -- All done, evaluate call and deal with elaboration issues @@ -5457,6 +5521,24 @@ package body Sem_Res is Warn_On_Overlapping_Actuals (Nam, N); end Resolve_Call; + ----------------------------- + -- Resolve_Case_Expression -- + ----------------------------- + + procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is + Alt : Node_Id; + + begin + Alt := First (Alternatives (N)); + while Present (Alt) loop + Resolve (Expression (Alt), Typ); + Next (Alt); + end loop; + + Set_Etype (N, Typ); + Eval_Case_Expression (N); + end Resolve_Case_Expression; + ------------------------------- -- Resolve_Character_Literal -- ------------------------------- @@ -5755,6 +5837,14 @@ package body Sem_Res is Set_Etype (N, Typ); Eval_Named_Real (N); + -- For enumeration literals, we need to make sure that a proper style + -- check is done, since such literals are overloaded, and thus we did + -- not do a style check during the first phase of analysis. + + elsif Ekind (E) = E_Enumeration_Literal then + Set_Entity_With_Style_Check (N, E); + Eval_Entity_Name (N); + -- Allow use of subtype only if it is a concurrent type where we are -- currently inside the body. This will eventually be expanded into a -- call to Self (for tasks) or _object (for protected objects). Any @@ -5809,7 +5899,6 @@ package body Sem_Res is and then not In_Spec_Expression and then not Is_Imported (E) then - if No_Initialization (Parent (E)) or else (Present (Full_View (E)) and then No_Initialization (Parent (Full_View (E)))) @@ -5860,7 +5949,7 @@ package body Sem_Res is -- to the discriminant of the same name in the target task. If the -- entry name is the target of a requeue statement and the entry is -- in the current protected object, the bound to be used is the - -- discriminal of the object (see apply_range_checks for details of + -- discriminal of the object (see Apply_Range_Checks for details of -- the transformation). ----------------------------- @@ -5883,7 +5972,14 @@ package body Sem_Res is and then In_Open_Scopes (Tsk) and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement then - return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); + -- Note: here Bound denotes a discriminant of the corresponding + -- record type tskV, whose discriminal is a formal of the + -- init-proc tskVIP. What we want is the body discriminal, + -- which is associated to the discriminant of the original + -- concurrent type tsk. + + return New_Occurrence_Of + (Find_Body_Discriminal (Entity (Bound)), Loc); else Ref := @@ -6163,9 +6259,7 @@ package body Sem_Res is Resolve_Actuals (N, Nam); Generate_Reference (Nam, Entry_Name); - if Ekind (Nam) = E_Entry - or else Ekind (Nam) = E_Entry_Family - then + if Ekind_In (Nam, E_Entry, E_Entry_Family) then Check_Potentially_Blocking_Operation (N); end if; @@ -6319,8 +6413,7 @@ package body Sem_Res is return; elsif T = Any_Access - or else Ekind (T) = E_Allocator_Type - or else Ekind (T) = E_Access_Attribute_Type + or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) then T := Find_Unique_Access_Type; @@ -6348,7 +6441,8 @@ package body Sem_Res is and then Entity (R) = Standard_True and then Comes_From_Source (R) then - Error_Msg_N ("?comparison with True is redundant!", R); + Error_Msg_N -- CODEFIX + ("?comparison with True is redundant!", R); end if; Check_Unset_Reference (L); @@ -6387,8 +6481,8 @@ package body Sem_Res is if Expander_Active and then - (Ekind (T) = E_Anonymous_Access_Type - or else Ekind (T) = E_Anonymous_Access_Subprogram_Type + (Ekind_In (T, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) or else Is_Private_Type (T)) then if Etype (L) /= T then @@ -6500,6 +6594,15 @@ package body Sem_Res is end Resolve_Explicit_Dereference; + ------------------------------------- + -- Resolve_Expression_With_Actions -- + ------------------------------------- + + procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + end Resolve_Expression_With_Actions; + ------------------------------- -- Resolve_Indexed_Component -- ------------------------------- @@ -6622,6 +6725,24 @@ package body Sem_Res is Warn_On_Suspicious_Index (Name, First (Expressions (N))); Eval_Indexed_Component (N); end if; + + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Indexed_Component + and then (Is_Atomic (Array_Type) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Bit_Packed_Array (Array_Type) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic array", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; end Resolve_Indexed_Component; ----------------------------- @@ -6639,12 +6760,20 @@ package body Sem_Res is -------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is - Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); - Op : Entity_Id; - Arg1 : Node_Id; - Arg2 : Node_Id; + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Orig_Op : constant Entity_Id := Entity (N); + Arg1 : Node_Id; + Arg2 : Node_Id; begin + -- We must preserve the original entity in a generic setting, so that + -- the legality of the operation can be verified in an instance. + + if not Expander_Active then + return; + end if; + Op := Entity (N); while Scope (Op) /= Standard_Standard loop Op := Homonym (Op); @@ -6667,8 +6796,13 @@ package body Sem_Res is Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); end if; - Save_Interps (Left_Opnd (N), Expression (Arg1)); - Save_Interps (Right_Opnd (N), Expression (Arg2)); + if Nkind (Arg1) = N_Type_Conversion then + Save_Interps (Left_Opnd (N), Expression (Arg1)); + end if; + + if Nkind (Arg2) = N_Type_Conversion then + Save_Interps (Right_Opnd (N), Expression (Arg2)); + end if; Set_Left_Opnd (N, Arg1); Set_Right_Opnd (N, Arg2); @@ -6681,19 +6815,31 @@ package body Sem_Res is or else Typ /= Etype (Right_Opnd (N)) then -- Add explicit conversion where needed, and save interpretations in - -- case operands are overloaded. + -- case operands are overloaded. If the context is a VMS operation, + -- assert that the conversion is legal (the operands have the proper + -- types to select the VMS intrinsic). Note that in rare cases the + -- VMS operators may be visible, but the default System is being used + -- and Address is a private type. Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N)); if Nkind (Arg1) = N_Type_Conversion then Save_Interps (Left_Opnd (N), Expression (Arg1)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg1); + end if; else Save_Interps (Left_Opnd (N), Arg1); end if; if Nkind (Arg2) = N_Type_Conversion then Save_Interps (Right_Opnd (N), Expression (Arg2)); + + if Is_VMS_Operator (Orig_Op) then + Set_Conversion_OK (Arg2); + end if; else Save_Interps (Right_Opnd (N), Arg2); end if; @@ -6893,6 +7039,18 @@ package body Sem_Res is T := Intersect_Types (L, R); end if; + -- If mixed-mode operations are present and operands are all literal, + -- the only interpretation involves Duration, which is probably not + -- the intention of the programmer. + + if T = Any_Fixed then + T := Unique_Fixed_Point_Type (N); + + if T = Any_Type then + return; + end if; + end if; + Resolve (L, T); Check_Unset_Reference (L); @@ -7702,7 +7860,6 @@ package body Sem_Res is Comp := Next_Entity (Comp); end loop; - end if; Get_Next_Interp (I, It); @@ -7740,9 +7897,7 @@ package body Sem_Res is end if; if Has_Discriminants (T) - and then (Ekind (Entity (S)) = E_Component - or else - Ekind (Entity (S)) = E_Discriminant) + and then Ekind_In (Entity (S), E_Component, E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component and then Present (Discriminant_Checking_Func @@ -7771,6 +7926,23 @@ package body Sem_Res is -- Note: No Eval processing is required, because the prefix is of a -- record type, or protected type, and neither can possibly be static. + -- If the array type is atomic, and is packed, and we are in a left side + -- context, then this is worth a warning, since we have a situation + -- where the access to the component may cause extra read/writes of + -- the atomic array object, which could be considered unexpected. + + if Nkind (N) = N_Selected_Component + and then (Is_Atomic (T) + or else (Is_Entity_Name (Prefix (N)) + and then Is_Atomic (Entity (Prefix (N))))) + and then Is_Packed (T) + and then Is_LHS (N) + then + Error_Msg_N ("?assignment to component of packed atomic record", + Prefix (N)); + Error_Msg_N ("?\may cause unexpected accesses to atomic object", + Prefix (N)); + end if; end Resolve_Selected_Component; ------------------- @@ -7807,8 +7979,11 @@ package body Sem_Res is R : constant Node_Id := Right_Opnd (N); begin + -- Why are the calls to Check_Order_Dependence commented out ??? Resolve (L, B_Typ); + -- Check_Order_Dependence; -- For AI05-0144 Resolve (R, B_Typ); + -- Check_Order_Dependence; -- For AI05-0144 -- Check for issuing warning for always False assert/check, this happens -- when assertions are turned off, in which case the pragma Assert/Check @@ -7982,6 +8157,7 @@ package body Sem_Res is end if; elsif Is_Entity_Name (Name) + or else Nkind (Name) = N_Explicit_Dereference or else (Nkind (Name) = N_Function_Call and then not Is_Constrained (Etype (Name))) then @@ -8475,7 +8651,7 @@ package body Sem_Res is (Etype (Entity (Orig_N)) = Orig_T or else (Ekind (Entity (Orig_N)) = E_Loop_Parameter - and then Covers (Orig_T, Etype (Entity (Orig_N))))) + and then Covers (Orig_T, Etype (Entity (Orig_N))))) then -- One more check, do not give warning if the analyzed conversion -- has an expression with non-static bounds, and the bounds of the @@ -8513,11 +8689,11 @@ package body Sem_Res is begin if Is_Access_Type (Opnd) then - Opnd := Directly_Designated_Type (Opnd); + Opnd := Designated_Type (Opnd); end if; if Is_Access_Type (Target_Typ) then - Target := Directly_Designated_Type (Target); + Target := Designated_Type (Target); end if; if Opnd = Target then @@ -8531,7 +8707,8 @@ package body Sem_Res is if From_With_Type (Opnd) then Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing WITH clause on package &", N, + Error_Msg_NE -- CODEFIX + ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); Error_Msg_N ("type conversions require visibility of the full view", @@ -8543,7 +8720,8 @@ package body Sem_Res is and then Present (Non_Limited_View (Etype (Target)))) then Error_Msg_Qual_Level := 99; - Error_Msg_NE ("missing WITH clause on package &", N, + Error_Msg_NE -- CODEFIX + ("missing WITH clause on package &", N, Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); Error_Msg_N ("type conversions require visibility of the full view", @@ -8559,9 +8737,7 @@ package body Sem_Res is -- Handle subtypes - if Ekind (Opnd) = E_Protected_Subtype - or else Ekind (Opnd) = E_Task_Subtype - then + if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then Opnd := Etype (Opnd); end if; @@ -8637,7 +8813,7 @@ package body Sem_Res is Determine_Range (Right_Opnd (N), OK, Lo, Hi); if OK and then Hi >= Lo and then Lo >= 0 then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?abs applied to known non-negative value has no effect", N); end if; end if; @@ -8861,9 +9037,7 @@ package body Sem_Res is -- Exclude user-defined intrinsic operations of the same name, which are -- treated separately and rewritten as calls. - if Ekind (Op) /= E_Function - or else Chars (N) /= Nam - then + if Ekind (Op) /= E_Function or else Chars (N) /= Nam then Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); Set_Chars (Op_Node, Nam); Set_Etype (Op_Node, Etype (N)); @@ -8902,9 +9076,8 @@ package body Sem_Res is end case; end if; - elsif Ekind (Op) = E_Function - and then Is_Intrinsic_Subprogram (Op) - then + elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then + -- Operator renames a user-defined operator of the same name. Use -- the original operator in the node, which is the one that Gigi -- knows about. @@ -8954,7 +9127,17 @@ package body Sem_Res is Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); - Set_Scalar_Range (Index_Subtype, Drange); + -- Take a new copy of Drange (where bounds have been rewritten to + -- reference side-effect-vree names). Using a separate tree ensures + -- that further expansion (e.g while rewriting a slice assignment + -- into a FOR loop) does not attempt to remove side effects on the + -- bounds again (which would cause the bounds in the index subtype + -- definition to refer to temporaries before they are defined) (the + -- reason is that some names are considered side effect free here + -- for the subtype, but not in the context of a loop iteration + -- scheme). + + Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); Set_Etype (Index_Subtype, Index_Type); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); @@ -8977,18 +9160,22 @@ package body Sem_Res is Set_Etype (N, Slice_Subtype); - -- In the packed case, this must be immediately frozen - - -- Couldn't we always freeze here??? and if we did, then the above - -- call to Check_Compile_Time_Size could be eliminated, which would - -- be nice, because then that routine could be made private to Freeze. - - -- Why the test for In_Spec_Expression here ??? + -- For packed slice subtypes, freeze immediately (except in the + -- case of being in a "spec expression" where we never freeze + -- when we first see the expression). if Is_Packed (Slice_Subtype) and not In_Spec_Expression then Freeze_Itype (Slice_Subtype, N); - end if; + -- For all other cases insert an itype reference in the slice's actions + -- so that the itype is frozen at the proper place in the tree (i.e. at + -- the point where actions for the slice are analyzed). Note that this + -- is different from freezing the itype immediately, which might be + -- premature (e.g. if the slice is within a transient scope). + + else + Ensure_Defined (Typ => Slice_Subtype, N => N); + end if; end Set_Slice_Subtype; -------------------------------- @@ -9330,9 +9517,8 @@ package body Sem_Res is -- out-of-scope references. elsif - (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type - or else - Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type) + Ekind_In (Target_Comp_Base, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) and then Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) @@ -9461,6 +9647,7 @@ package body Sem_Res is It : Interp; It1 : Interp; N1 : Entity_Id; + T1 : Entity_Id; begin -- Remove procedure calls, which syntactically cannot appear in @@ -9517,16 +9704,30 @@ package body Sem_Res is if Present (It.Typ) then N1 := It1.Nam; + T1 := It1.Typ; It1 := Disambiguate (Operand, I1, I, Any_Type); if It1 = No_Interp then Error_Msg_N ("ambiguous operand in conversion", Operand); - Error_Msg_Sloc := Sloc (It.Nam); + -- If the interpretation involves a standard operator, use + -- the location of the type, which may be user-defined. + + if Sloc (It.Nam) = Standard_Location then + Error_Msg_Sloc := Sloc (It.Typ); + else + Error_Msg_Sloc := Sloc (It.Nam); + end if; + Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); - Error_Msg_Sloc := Sloc (N1); + if Sloc (N1) = Standard_Location then + Error_Msg_Sloc := Sloc (T1); + else + Error_Msg_Sloc := Sloc (N1); + end if; + Error_Msg_N -- CODEFIX ("\\possible interpretation#!", Operand); @@ -9588,9 +9789,8 @@ package body Sem_Res is -- Ada 2005 (AI-251): Anonymous access types where target references an -- interface type. - elsif (Ekind (Target_Type) = E_General_Access_Type - or else - Ekind (Target_Type) = E_Anonymous_Access_Type) + elsif Ekind_In (Target_Type, E_General_Access_Type, + E_Anonymous_Access_Type) and then Is_Interface (Directly_Designated_Type (Target_Type)) then -- Check the static accessibility rule of 4.6(17). Note that the @@ -9659,8 +9859,8 @@ package body Sem_Res is if Is_Entity_Name (Operand) and then not Is_Local_Anonymous_Access (Opnd_Type) - and then (Ekind (Entity (Operand)) = E_In_Parameter - or else Ekind (Entity (Operand)) = E_Constant) + and then + Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N @@ -9675,15 +9875,14 @@ package body Sem_Res is -- General and anonymous access types - elsif (Ekind (Target_Type) = E_General_Access_Type - or else Ekind (Target_Type) = E_Anonymous_Access_Type) + elsif Ekind_In (Target_Type, E_General_Access_Type, + E_Anonymous_Access_Type) and then Conversion_Check (Is_Access_Type (Opnd_Type) - and then Ekind (Opnd_Type) /= - E_Access_Subprogram_Type - and then Ekind (Opnd_Type) /= - E_Access_Protected_Subprogram_Type, + and then not + Ekind_In (Opnd_Type, E_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type), "must be an access-to-object type") then if Is_Access_Constant (Opnd_Type) @@ -9733,7 +9932,6 @@ package body Sem_Res is elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type and then not Is_Local_Anonymous_Access (Opnd_Type) then - -- When the operand is a selected access discriminant the check -- needs to be made against the level of the object denoted by -- the prefix of the selected name (Object_Access_Level handles @@ -9770,8 +9968,8 @@ package body Sem_Res is -- access type. if Is_Entity_Name (Operand) - and then (Ekind (Entity (Operand)) = E_In_Parameter - or else Ekind (Entity (Operand)) = E_Constant) + and then + Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) and then Present (Discriminal_Link (Entity (Operand))) then Error_Msg_N @@ -9991,7 +10189,8 @@ package body Sem_Res is and then Is_Access_Type (Opnd_Type) then Error_Msg_N ("target type must be general access type!", N); - Error_Msg_NE ("add ALL to }!", N, Target_Type); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", N, Target_Type); return False; else diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index 5adf803fc70..3ab7511663e 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,649 +23,170 @@ -- -- ------------------------------------------------------------------------------ -with Einfo; use Einfo; -with Namet; use Namet; -with Nlists; use Nlists; -with Opt; use Opt; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Stand; use Stand; +with Einfo; use Einfo; +with Nlists; use Nlists; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sinfo; use Sinfo; +with Stand; use Stand; +with SCIL_LL; use SCIL_LL; package body Sem_SCIL is - ---------------------- - -- Adjust_SCIL_Node -- - ---------------------- - - procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is - SCIL_Node : Node_Id; - - begin - pragma Assert (Generate_SCIL); - - -- Check cases in which no action is required. Currently the only SCIL - -- nodes that may require adjustment are those of dispatching calls - -- internally generated by the frontend. - - if Comes_From_Source (Old_Node) - or else not - Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement) - then - return; - - -- Conditional expression associated with equality operator. Old_Node - -- may be part of the expansion of the predefined equality operator of - -- a tagged type and hence we need to check if it has a SCIL dispatching - -- node that needs adjustment. - - elsif Nkind (Old_Node) = N_Conditional_Expression - and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq - or else - (Nkind (Original_Node (Old_Node)) = N_Function_Call - and then Chars (Name (Original_Node (Old_Node))) = - Name_Op_Eq)) - then - null; - - -- Type conversions may involve dispatching calls to functions whose - -- associated SCIL dispatching node needs adjustment. - - elsif Nkind_In (Old_Node, N_Type_Conversion, - N_Unchecked_Type_Conversion) - then - null; - - -- Relocated subprogram call - - elsif Nkind (Old_Node) = Nkind (New_Node) - and then Original_Node (Old_Node) = Original_Node (New_Node) - then - null; - - else - return; - end if; - - -- Search for the SCIL node and update it (if found) - - SCIL_Node := Find_SCIL_Node (Old_Node); - - if Present (SCIL_Node) then - Set_SCIL_Related_Node (SCIL_Node, New_Node); - end if; - end Adjust_SCIL_Node; - --------------------- -- Check_SCIL_Node -- --------------------- function Check_SCIL_Node (N : Node_Id) return Traverse_Result is - Ctrl_Tag : Node_Id; - Ctrl_Typ : Entity_Id; + SCIL_Node : constant Node_Id := Get_SCIL_Node (N); + Ctrl_Tag : Node_Id; + Ctrl_Typ : Entity_Id; begin - if Nkind (N) = N_SCIL_Membership_Test then - - -- Check contents of the boolean expression associated with the - -- membership test. - - pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier - and then Etype (SCIL_Related_Node (N)) = Standard_Boolean); - - -- Check the entity identifier of the associated tagged type (that - -- is, in testing for membership in T'Class, the entity id of the - -- specific type T). - - -- Note: When the SCIL node is generated the private and full-view - -- of the tagged types may have been swapped and hence the node - -- referenced by attribute SCIL_Entity may be the private view. - -- Therefore, in order to uniformily locate the full-view we use - -- attribute Underlying_Type. + -- For nodes that do not have SCIL node continue traversing the tree - pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N)))); - - -- Interface types are unsupported - - pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N)))); - - -- Check the decoration of the expression that denotes the tag value - -- being tested - - Ctrl_Tag := SCIL_Tag_Value (N); + if No (SCIL_Node) then + return OK; + end if; - case Nkind (Ctrl_Tag) is + case Nkind (SCIL_Node) is + when N_SCIL_Dispatch_Table_Tag_Init => + pragma Assert (Nkind (N) = N_Object_Declaration); + null; - -- For class-wide membership tests the SCIL tag value is the tag - -- of the tested object (i.e. Obj.Tag). + when N_SCIL_Dispatching_Call => + Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node); - when N_Selected_Component => - pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); - null; + -- Parent of SCIL dispatching call nodes MUST be a subprogram call - when others => + if not Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) + then pragma Assert (False); - null; - - end case; - - return Skip; + raise Program_Error; - elsif Nkind (N) = N_SCIL_Dispatching_Call then - Ctrl_Tag := SCIL_Controlling_Tag (N); + -- In simple cases the controlling tag is the tag of the + -- controlling argument (i.e. Obj.Tag). - -- SCIL_Related_Node of SCIL dispatching call nodes MUST reference - -- subprogram calls. + elsif Nkind (Ctrl_Tag) = N_Selected_Component then + Ctrl_Typ := Etype (Ctrl_Tag); - if not Nkind_In (SCIL_Related_Node (N), N_Function_Call, - N_Procedure_Call_Statement) - then - pragma Assert (False); - raise Program_Error; + -- Interface types are unsupported - -- In simple cases the controlling tag is the tag of the controlling - -- argument (i.e. Obj.Tag). + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + then + null; - elsif Nkind (Ctrl_Tag) = N_Selected_Component then - Ctrl_Typ := Etype (Ctrl_Tag); + else + pragma Assert (Ctrl_Typ = RTE (RE_Tag)); + null; + end if; - -- Interface types are unsupported + -- When the controlling tag of a dispatching call is an identifier + -- the SCIL_Controlling_Tag attribute references the corresponding + -- object or parameter declaration. Interface types are still + -- unsupported. - if Is_Interface (Ctrl_Typ) - or else (RTE_Available (RE_Interface_Tag) - and then Ctrl_Typ = RTE (RE_Interface_Tag)) + elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, + N_Parameter_Specification) then - null; + Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); + + -- Interface types are unsupported. + + if Is_Interface (Ctrl_Typ) + or else (RTE_Available (RE_Interface_Tag) + and then Ctrl_Typ = RTE (RE_Interface_Tag)) + or else (Is_Access_Type (Ctrl_Typ) + and then + Is_Interface + (Available_View + (Base_Type (Designated_Type (Ctrl_Typ))))) + then + null; - else - pragma Assert (Ctrl_Typ = RTE (RE_Tag)); - null; - end if; + else + pragma Assert + (Ctrl_Typ = RTE (RE_Tag) + or else + (Is_Access_Type (Ctrl_Typ) + and then Available_View + (Base_Type (Designated_Type (Ctrl_Typ))) + = RTE (RE_Tag))); + null; + end if; - -- When the controlling tag of a dispatching call is an identifier - -- the SCIL_Controlling_Tag attribute references the corresponding - -- object or parameter declaration. Interface types are still - -- unsupported. - - elsif Nkind_In (Ctrl_Tag, N_Object_Declaration, - N_Parameter_Specification) - then - Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag)); - - -- Interface types are unsupported. - - if Is_Interface (Ctrl_Typ) - or else (RTE_Available (RE_Interface_Tag) - and then Ctrl_Typ = RTE (RE_Interface_Tag)) - or else (Is_Access_Type (Ctrl_Typ) - and then - Is_Interface - (Available_View - (Base_Type (Designated_Type (Ctrl_Typ))))) - then - null; + -- Interface types are unsupported - else - pragma Assert - (Ctrl_Typ = RTE (RE_Tag) - or else - (Is_Access_Type (Ctrl_Typ) - and then Available_View - (Base_Type (Designated_Type (Ctrl_Typ))) = - RTE (RE_Tag))); + elsif Is_Interface (Etype (Ctrl_Tag)) then null; - end if; - - -- Interface types are unsupported - - elsif Is_Interface (Etype (Ctrl_Tag)) then - null; - else - pragma Assert (False); - raise Program_Error; - end if; - - return Skip; - - -- Node is not N_SCIL_Dispatching_Call - - else - return OK; - end if; - end Check_SCIL_Node; - - -------------------- - -- Find_SCIL_Node -- - -------------------- - - function Find_SCIL_Node (Node : Node_Id) return Node_Id is - Found_Node : Node_Id; - -- This variable stores the last node found by the nested subprogram - -- Find_SCIL_Node. - - function Find_SCIL_Node (L : List_Id) return Boolean; - -- Searches in list L for a SCIL node associated with a dispatching call - -- whose SCIL_Related_Node is Node. If found returns true and stores the - -- SCIL node in Found_Node; otherwise returns False and sets Found_Node - -- to Empty. - - -------------------- - -- Find_SCIL_Node -- - -------------------- - - function Find_SCIL_Node (L : List_Id) return Boolean is - N : Node_Id; - - begin - N := First (L); - while Present (N) loop - if Nkind (N) in N_SCIL_Node - and then SCIL_Related_Node (N) = Node - then - Found_Node := N; - return True; + else + pragma Assert (False); + raise Program_Error; end if; - Next (N); - end loop; + return Skip; - Found_Node := Empty; - return False; - end Find_SCIL_Node; + when N_SCIL_Membership_Test => - -- Local variables + -- Check contents of the boolean expression associated with the + -- membership test. - P : Node_Id; + pragma Assert (Nkind_In (N, N_Identifier, + N_And_Then, + N_Or_Else, + N_Expression_With_Actions) + and then Etype (N) = Standard_Boolean); - -- Start of processing for Find_SCIL_Node + -- Check the entity identifier of the associated tagged type (that + -- is, in testing for membership in T'Class, the entity id of the + -- specific type T). - begin - pragma Assert (Generate_SCIL); - - -- Search for the SCIL node in list associated with a transient scope - - if Scope_Is_Transient then - declare - SE : Scope_Stack_Entry - renames Scope_Stack.Table (Scope_Stack.Last); - begin - if SE.Is_Transient - and then Present (SE.Actions_To_Be_Wrapped_Before) - and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before) - then - return Found_Node; - end if; - end; - end if; - - -- Otherwise climb up the tree searching for the SCIL node analyzing - -- all the lists in which Insert_Actions may have inserted it - - P := Node; - while Present (P) loop - case Nkind (P) is + -- Note: When the SCIL node is generated the private and full-view + -- of the tagged types may have been swapped and hence the node + -- referenced by attribute SCIL_Entity may be the private view. + -- Therefore, in order to uniformily locate the full-view we use + -- attribute Underlying_Type. - -- Actions associated with AND THEN or OR ELSE + pragma Assert + (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node)))); - when N_Short_Circuit => - if Present (Actions (P)) - and then Find_SCIL_Node (Actions (P)) - then - return Found_Node; - end if; - - -- Actions of conditional expressions - - when N_Conditional_Expression => - if (Present (Then_Actions (P)) - and then Find_SCIL_Node (Actions (P))) - or else - (Present (Else_Actions (P)) - and then Find_SCIL_Node (Else_Actions (P))) - then - return Found_Node; - end if; - - -- Actions in handled sequence of statements + -- Interface types are unsupported - when - N_Handled_Sequence_Of_Statements => - if Find_SCIL_Node (Statements (P)) then - return Found_Node; - end if; + pragma Assert + (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node)))); - -- Conditions of while expression or elsif. + -- Check the decoration of the expression that denotes the tag + -- value being tested - when N_Iteration_Scheme | - N_Elsif_Part - => - if Present (Condition_Actions (P)) - and then Find_SCIL_Node (Condition_Actions (P)) - then - return Found_Node; - end if; + Ctrl_Tag := SCIL_Tag_Value (SCIL_Node); - -- Statements, declarations, pragmas, representation clauses - - when - -- Statements - - N_Procedure_Call_Statement | - N_Statement_Other_Than_Procedure_Call | - - -- Pragmas - - N_Pragma | - - -- Representation_Clause - - N_At_Clause | - N_Attribute_Definition_Clause | - N_Enumeration_Representation_Clause | - N_Record_Representation_Clause | - - -- Declarations - - N_Abstract_Subprogram_Declaration | - N_Entry_Body | - N_Exception_Declaration | - N_Exception_Renaming_Declaration | - N_Formal_Abstract_Subprogram_Declaration | - N_Formal_Concrete_Subprogram_Declaration | - N_Formal_Object_Declaration | - N_Formal_Type_Declaration | - N_Full_Type_Declaration | - N_Function_Instantiation | - N_Generic_Function_Renaming_Declaration | - N_Generic_Package_Declaration | - N_Generic_Package_Renaming_Declaration | - N_Generic_Procedure_Renaming_Declaration | - N_Generic_Subprogram_Declaration | - N_Implicit_Label_Declaration | - N_Incomplete_Type_Declaration | - N_Number_Declaration | - N_Object_Declaration | - N_Object_Renaming_Declaration | - N_Package_Body | - N_Package_Body_Stub | - N_Package_Declaration | - N_Package_Instantiation | - N_Package_Renaming_Declaration | - N_Private_Extension_Declaration | - N_Private_Type_Declaration | - N_Procedure_Instantiation | - N_Protected_Body | - N_Protected_Body_Stub | - N_Protected_Type_Declaration | - N_Single_Task_Declaration | - N_Subprogram_Body | - N_Subprogram_Body_Stub | - N_Subprogram_Declaration | - N_Subprogram_Renaming_Declaration | - N_Subtype_Declaration | - N_Task_Body | - N_Task_Body_Stub | - N_Task_Type_Declaration | - - -- Freeze entity behaves like a declaration or statement - - N_Freeze_Entity - => - -- Do not search here if the item is not a list member - - if not Is_List_Member (P) then - null; + case Nkind (Ctrl_Tag) is - -- Do not search if parent of P is an N_Component_Association - -- node (i.e. we are in the context of an N_Aggregate or - -- N_Extension_Aggregate node). In this case the node should - -- have been added before the entire aggregate. + -- For class-wide membership tests the SCIL tag value is the + -- tag of the tested object (i.e. Obj.Tag). - elsif Nkind (Parent (P)) = N_Component_Association then + when N_Selected_Component => + pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag)); null; - -- Do not search if the parent of P is either an N_Variant - -- node or an N_Record_Definition node. In this case the node - -- should have been added before the entire record. - - elsif Nkind (Parent (P)) = N_Variant - or else Nkind (Parent (P)) = N_Record_Definition - then + when others => + pragma Assert (False); null; + end case; - -- Otherwise search it in the list containing this node - - elsif Find_SCIL_Node (List_Containing (P)) then - return Found_Node; - end if; - - -- A special case, N_Raise_xxx_Error can act either as a statement - -- or a subexpression. We diferentiate them by looking at the - -- Etype. It is set to Standard_Void_Type in the statement case. - - when - N_Raise_xxx_Error => - if Etype (P) = Standard_Void_Type then - if Is_List_Member (P) - and then Find_SCIL_Node (List_Containing (P)) - then - return Found_Node; - end if; - - -- In the subexpression case, keep climbing - - else - null; - end if; - - -- If a component association appears within a loop created for - -- an array aggregate, check if the SCIL node was added to the - -- the list of nodes attached to the association. - - when - N_Component_Association => - if Nkind (Parent (P)) = N_Aggregate - and then Present (Loop_Actions (P)) - and then Find_SCIL_Node (Loop_Actions (P)) - then - return Found_Node; - end if; - - -- Another special case, an attribute denoting a procedure call - - when - N_Attribute_Reference => - if Is_Procedure_Attribute_Name (Attribute_Name (P)) - and then Find_SCIL_Node (List_Containing (P)) - then - return Found_Node; - - -- In the subexpression case, keep climbing - - else - null; - end if; - - -- SCIL nodes do not have subtrees and hence they can never be - -- found climbing tree - - when - N_SCIL_Dispatch_Table_Object_Init | - N_SCIL_Dispatch_Table_Tag_Init | - N_SCIL_Dispatching_Call | - N_SCIL_Membership_Test | - N_SCIL_Tag_Init - => - pragma Assert (False); - raise Program_Error; - - -- For all other node types, keep climbing tree - - when - N_Abortable_Part | - N_Accept_Alternative | - N_Access_Definition | - N_Access_Function_Definition | - N_Access_Procedure_Definition | - N_Access_To_Object_Definition | - N_Aggregate | - N_Allocator | - N_Case_Statement_Alternative | - N_Character_Literal | - N_Compilation_Unit | - N_Compilation_Unit_Aux | - N_Component_Clause | - N_Component_Declaration | - N_Component_Definition | - N_Component_List | - N_Constrained_Array_Definition | - N_Decimal_Fixed_Point_Definition | - N_Defining_Character_Literal | - N_Defining_Identifier | - N_Defining_Operator_Symbol | - N_Defining_Program_Unit_Name | - N_Delay_Alternative | - N_Delta_Constraint | - N_Derived_Type_Definition | - N_Designator | - N_Digits_Constraint | - N_Discriminant_Association | - N_Discriminant_Specification | - N_Empty | - N_Entry_Body_Formal_Part | - N_Entry_Call_Alternative | - N_Entry_Declaration | - N_Entry_Index_Specification | - N_Enumeration_Type_Definition | - N_Error | - N_Exception_Handler | - N_Expanded_Name | - N_Explicit_Dereference | - N_Extension_Aggregate | - N_Floating_Point_Definition | - N_Formal_Decimal_Fixed_Point_Definition | - N_Formal_Derived_Type_Definition | - N_Formal_Discrete_Type_Definition | - N_Formal_Floating_Point_Definition | - N_Formal_Modular_Type_Definition | - N_Formal_Ordinary_Fixed_Point_Definition | - N_Formal_Package_Declaration | - N_Formal_Private_Type_Definition | - N_Formal_Signed_Integer_Type_Definition | - N_Function_Call | - N_Function_Specification | - N_Generic_Association | - N_Identifier | - N_In | - N_Index_Or_Discriminant_Constraint | - N_Indexed_Component | - N_Integer_Literal | - N_Itype_Reference | - N_Label | - N_Loop_Parameter_Specification | - N_Mod_Clause | - N_Modular_Type_Definition | - N_Not_In | - N_Null | - N_Op_Abs | - N_Op_Add | - N_Op_And | - N_Op_Concat | - N_Op_Divide | - N_Op_Eq | - N_Op_Expon | - N_Op_Ge | - N_Op_Gt | - N_Op_Le | - N_Op_Lt | - N_Op_Minus | - N_Op_Mod | - N_Op_Multiply | - N_Op_Ne | - N_Op_Not | - N_Op_Or | - N_Op_Plus | - N_Op_Rem | - N_Op_Rotate_Left | - N_Op_Rotate_Right | - N_Op_Shift_Left | - N_Op_Shift_Right | - N_Op_Shift_Right_Arithmetic | - N_Op_Subtract | - N_Op_Xor | - N_Operator_Symbol | - N_Ordinary_Fixed_Point_Definition | - N_Others_Choice | - N_Package_Specification | - N_Parameter_Association | - N_Parameter_Specification | - N_Pop_Constraint_Error_Label | - N_Pop_Program_Error_Label | - N_Pop_Storage_Error_Label | - N_Pragma_Argument_Association | - N_Procedure_Specification | - N_Protected_Definition | - N_Push_Constraint_Error_Label | - N_Push_Program_Error_Label | - N_Push_Storage_Error_Label | - N_Qualified_Expression | - N_Range | - N_Range_Constraint | - N_Real_Literal | - N_Real_Range_Specification | - N_Record_Definition | - N_Reference | - N_Selected_Component | - N_Signed_Integer_Type_Definition | - N_Single_Protected_Declaration | - N_Slice | - N_String_Literal | - N_Subprogram_Info | - N_Subtype_Indication | - N_Subunit | - N_Task_Definition | - N_Terminate_Alternative | - N_Triggering_Alternative | - N_Type_Conversion | - N_Unchecked_Expression | - N_Unchecked_Type_Conversion | - N_Unconstrained_Array_Definition | - N_Unused_At_End | - N_Unused_At_Start | - N_Use_Package_Clause | - N_Use_Type_Clause | - N_Variant | - N_Variant_Part | - N_Validate_Unchecked_Conversion | - N_With_Clause - => - null; - - end case; - - -- If we fall through above tests, keep climbing tree - - if Nkind (Parent (P)) = N_Subunit then - - -- This is the proper body corresponding to a stub. Insertion done - -- at the point of the stub, which is in the declarative part of - -- the parent unit. + return Skip; - P := Corresponding_Stub (Parent (P)); - - else - P := Parent (P); - end if; - end loop; - - -- SCIL node not found + when others => + pragma Assert (False); + raise Program_Error; + end case; - return Empty; - end Find_SCIL_Node; + return Skip; + end Check_SCIL_Node; ------------------------- -- First_Non_SCIL_Node -- diff --git a/gcc/ada/sem_scil.ads b/gcc/ada/sem_scil.ads index f257e636295..1a6e45caacb 100644 --- a/gcc/ada/sem_scil.ads +++ b/gcc/ada/sem_scil.ads @@ -4,9 +4,9 @@ -- -- -- S E M _ S C I L -- -- -- --- B o d y -- +-- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2010, 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- -- @@ -33,10 +33,6 @@ package Sem_SCIL is -- Here would be a good place to document what SCIL is all about ??? - procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id); - -- Searches for a SCIL dispatching node associated with Old_Node. If found - -- then update its SCIL_Related_Node field to reference New_Node. - function Check_SCIL_Node (N : Node_Id) return Traverse_Result; -- Process a single node during the tree traversal. Done to verify that -- SCIL nodes decoration fulfill the requirements of the SCIL backend. @@ -44,10 +40,6 @@ package Sem_SCIL is procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node); -- The traversal procedure itself - function Find_SCIL_Node (Node : Node_Id) return Node_Id; - -- Searches for a SCIL dispatching node associated with Node. If not found - -- then return Empty. - function First_Non_SCIL_Node (L : List_Id) return Node_Id; -- Returns the first non-SCIL node of list L diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index d35326e1a50..b1962861556 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -362,7 +362,6 @@ package body Sem_Type is -- performed, given that the operator was visible in the generic. if Ekind (E) = E_Operator then - if Present (Opnd_Type) then Vis_Type := Opnd_Type; else @@ -803,8 +802,8 @@ package body Sem_Type is then return True; - -- The context may be class wide, and a class-wide type is - -- compatible with any member of the class. + -- The context may be class wide, and a class-wide type is compatible + -- with any member of the class. elsif Is_Class_Wide_Type (T1) and then Is_Ancestor (Root_Type (T1), T2) @@ -997,9 +996,7 @@ package body Sem_Type is -- imposed by context. elsif Ekind (T2) = E_Access_Attribute_Type - and then (Ekind (BT1) = E_General_Access_Type - or else - Ekind (BT1) = E_Access_Type) + and then Ekind_In (BT1, E_General_Access_Type, E_Access_Type) and then Covers (Designated_Type (T1), Designated_Type (T2)) then -- If the target type is a RACW type while the source is an access @@ -1677,9 +1674,8 @@ package body Sem_Type is elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration and then Present (Access_Definition (Parent (N))) then - if Ekind (It1.Typ) = E_Anonymous_Access_Type - or else - Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type + if Ekind_In (It1.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then if Ekind (It2.Typ) = Ekind (It1.Typ) then @@ -1691,9 +1687,8 @@ package body Sem_Type is return It1; end if; - elsif Ekind (It2.Typ) = E_Anonymous_Access_Type - or else - Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type + elsif Ekind_In (It2.Typ, E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then return It2; @@ -1880,8 +1875,8 @@ package body Sem_Type is if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type and then - List_Containing (Parent (Designated_Type (Etype (Opnd)))) - = List_Containing (Unit_Declaration_Node (User_Subp)) + List_Containing (Parent (Designated_Type (Etype (Opnd)))) + = List_Containing (Unit_Declaration_Node (User_Subp)) then if It2.Nam = Predef_Subp then return It1; @@ -2559,9 +2554,9 @@ package body Sem_Type is BT1 := Base_Type (T1); BT2 := Base_Type (T2); - -- Handle underlying view of records with unknown discriminants - -- using the original entity that motivated the construction of - -- this underlying record view (see Build_Derived_Private_Type). + -- Handle underlying view of records with unknown discriminants using + -- the original entity that motivated the construction of this + -- underlying record view (see Build_Derived_Private_Type). if Is_Underlying_Record_View (BT1) then BT1 := Underlying_Record_View (BT1); @@ -2574,12 +2569,20 @@ package body Sem_Type is if BT1 = BT2 then return True; + -- The predicate must look past privacy + elsif Is_Private_Type (T1) and then Present (Full_View (T1)) and then BT2 = Base_Type (Full_View (T1)) then return True; + elsif Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then BT1 = Base_Type (Full_View (T2)) + then + return True; + else Par := Etype (BT2); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1cfa423eadd..e846845ca70 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -50,19 +50,20 @@ with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_SCIL; use Sem_SCIL; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; with Style; with Stringt; use Stringt; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uname; use Uname; with GNAT.HTable; use GNAT.HTable; + package body Sem_Util is ---------------------------------------- @@ -94,6 +95,30 @@ package body Sem_Util is subtype NCT_Header_Num is Int range 0 .. 511; -- Defines range of headers in hash tables (512 headers) + ---------------------------------- + -- Order Dependence (AI05-0144) -- + ---------------------------------- + + -- Each actual in a call is entered into the table below. A flag indicates + -- whether the corresponding formal is OUT or IN OUT. Each top-level call + -- (procedure call, condition, assignment) examines all the actuals for a + -- possible order dependence. The table is reset after each such check. + + type Actual_Name is record + Act : Node_Id; + Is_Writable : Boolean; + -- Comments needed??? + + end record; + + package Actuals_In_Call is new Table.Table ( + Table_Component_Type => Actual_Name, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Actuals"); + ----------------------- -- Local Subprograms -- ----------------------- @@ -398,9 +423,7 @@ package body Sem_Util is end loop; end if; - Subt := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Subt := Make_Temporary (Loc, 'S', Related_Node => N); Set_Is_Internal (Subt); Decl := @@ -624,9 +647,7 @@ package body Sem_Util is return Empty; end if; - Subt := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + Subt := Make_Temporary (Loc, 'S'); Set_Is_Internal (Subt); Decl := @@ -666,10 +687,7 @@ package body Sem_Util is end if; declare - Act : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); - + Act : constant Entity_Id := Make_Temporary (Loc, 'S'); Constraints : constant List_Id := New_List; Decl : Node_Id; @@ -1151,6 +1169,53 @@ package body Sem_Util is end if; end Check_Nested_Access; + ---------------------------- + -- Check_Order_Dependence -- + ---------------------------- + + procedure Check_Order_Dependence is + Act1 : Node_Id; + Act2 : Node_Id; + + begin + -- This could use comments ??? + + for J in 0 .. Actuals_In_Call.Last loop + if Actuals_In_Call.Table (J).Is_Writable then + Act1 := Actuals_In_Call.Table (J).Act; + + if Nkind (Act1) = N_Attribute_Reference then + Act1 := Prefix (Act1); + end if; + + for K in 0 .. Actuals_In_Call.Last loop + if K /= J then + Act2 := Actuals_In_Call.Table (K).Act; + + if Nkind (Act2) = N_Attribute_Reference then + Act2 := Prefix (Act2); + end if; + + if Actuals_In_Call.Table (K).Is_Writable + and then K < J + then + -- Already checked + + null; + + elsif Denotes_Same_Object (Act1, Act2) + and then False + then + Error_Msg_N ("?,mighty suspicious!!!", Act1); + end if; + end if; + end loop; + end if; + end loop; + + Actuals_In_Call.Set_Last (0); + end Check_Order_Dependence; + ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -1677,18 +1742,40 @@ package body Sem_Util is and then (not Formal_Derived or else Present (Alias (Id))) then - Append_Elmt (Id, Op_List); + -- In the special case of an equality operator aliased to + -- an overriding dispatching equality belonging to the same + -- type, we don't include it in the list of primitives. + -- This avoids inheriting multiple equality operators when + -- deriving from untagged private types whose full type is + -- tagged, which can otherwise cause ambiguities. Note that + -- this should only happen for this kind of untagged parent + -- type, since normally dispatching operations are inherited + -- using the type's Primitive_Operations list. + + if Chars (Id) = Name_Op_Eq + and then Is_Dispatching_Operation (Id) + and then Present (Alias (Id)) + and then Is_Overriding_Operation (Alias (Id)) + and then Base_Type (Etype (First_Entity (Id))) = + Base_Type (Etype (First_Entity (Alias (Id)))) + then + null; + + -- Include the subprogram in the list of primitives + + else + Append_Elmt (Id, Op_List); + end if; end if; end if; Next_Entity (Id); - -- For a type declared in System, some of its operations - -- may appear in the target-specific extension to System. + -- For a type declared in System, some of its operations may + -- appear in the target-specific extension to System. if No (Id) - and then Chars (B_Scope) = Name_System - and then Scope (B_Scope) = Standard_Standard + and then B_Scope = RTU_Entity (System) and then Present_System_Aux then B_Scope := System_Aux_Id; @@ -2080,9 +2167,7 @@ package body Sem_Util is -- so we can continue semantic analysis elsif Nam = Error then - Err := - Make_Defining_Identifier (Sloc (N), - Chars => New_Internal_Name ('T')); + Err := Make_Temporary (Sloc (N), 'T'); Set_Defining_Unit_Name (N, Err); return Err; @@ -2238,7 +2323,9 @@ package body Sem_Util is begin if Is_Entity_Name (A1) then - if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then + if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) + and then not Is_Access_Type (Etype (A1)) + then return Denotes_Same_Object (A1, Prefix (A2)) or else Denotes_Same_Prefix (A1, Prefix (A2)); else @@ -2558,7 +2645,12 @@ package body Sem_Util is elsif Ekind (Dynamic_Scope) = E_Task_Type then return Get_Task_Body_Procedure (Dynamic_Scope); - elsif Convention (Dynamic_Scope) = Convention_Protected then + -- No body is generated if the protected operation is eliminated + + elsif Convention (Dynamic_Scope) = Convention_Protected + and then not Is_Eliminated (Dynamic_Scope) + and then Present (Protected_Body_Subprogram (Dynamic_Scope)) + then return Protected_Body_Subprogram (Dynamic_Scope); else @@ -2817,9 +2909,7 @@ package body Sem_Util is -- Avoid cascaded messages with duplicate components in -- derived types. - if Ekind (E) = E_Component - or else Ekind (E) = E_Discriminant - then + if Ekind_In (E, E_Component, E_Discriminant) then return; end if; end if; @@ -2854,9 +2944,7 @@ package body Sem_Util is -- midst of inheriting components in a derived record definition. -- Preserve their Ekind and Etype. - if Ekind (Def_Id) = E_Discriminant - or else Ekind (Def_Id) = E_Component - then + if Ekind_In (Def_Id, E_Discriminant, E_Component) then null; -- If a type is already set, leave it alone (happens whey a type @@ -2876,8 +2964,7 @@ package body Sem_Util is -- Inherited discriminants and components in derived record types are -- immediately visible. Itypes are not. - if Ekind (Def_Id) = E_Discriminant - or else Ekind (Def_Id) = E_Component + if Ekind_In (Def_Id, E_Discriminant, E_Component) or else (No (Corresponding_Remote_Type (Def_Id)) and then not Is_Itype (Def_Id)) then @@ -3048,6 +3135,38 @@ package body Sem_Util is Call := Empty; end Find_Actual; + --------------------------- + -- Find_Body_Discriminal -- + --------------------------- + + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id + is + pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant))); + + Tsk : constant Entity_Id := + Corresponding_Concurrent_Type (Scope (Spec_Discriminant)); + Disc : Entity_Id; + + begin + -- Find discriminant of original concurrent type, and use its current + -- discriminal, which is the renaming within the task/protected body. + + Disc := First_Discriminant (Tsk); + while Present (Disc) loop + if Chars (Disc) = Chars (Spec_Discriminant) then + return Discriminal (Disc); + end if; + + Next_Discriminant (Disc); + end loop; + + -- That loop should always succeed in finding a matching entry and + -- returning. Fatal error if not. + + raise Program_Error; + end Find_Body_Discriminal; + ------------------------------------- -- Find_Corresponding_Discriminant -- ------------------------------------- @@ -4452,15 +4571,13 @@ package body Sem_Util is (T : Entity_Id; Use_Full_View : Boolean := True) return Boolean is - Typ : Entity_Id; + Typ : Entity_Id := Base_Type (T); begin -- Handle concurrent types - if Is_Concurrent_Type (T) then - Typ := Corresponding_Record_Type (T); - else - Typ := T; + if Is_Concurrent_Type (Typ) then + Typ := Corresponding_Record_Type (Typ); end if; if not Present (Typ) @@ -4848,10 +4965,8 @@ package body Sem_Util is -- We are interested only in components and discriminants - if Ekind (Ent) = E_Component - or else - Ekind (Ent) = E_Discriminant - then + if Ekind_In (Ent, E_Component, E_Discriminant) then + -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and -- tag fields are examples of such entities. For these cases, @@ -5406,15 +5521,6 @@ package body Sem_Util is begin Save_Interps (N, New_Prefix); - -- Check if the node relocation requires readjustment of some SCIL - -- dispatching node. - - if Generate_SCIL - and then Nkind (N) = N_Function_Call - then - Adjust_SCIL_Node (N, New_Prefix); - end if; - Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix)); Set_Etype (N, Designated_Type (Etype (New_Prefix))); @@ -5700,7 +5806,14 @@ package body Sem_Util is -- Start of processing for Is_Atomic_Object begin - if Is_Atomic (Etype (N)) + -- Predicate is not relevant to subprograms + + if Is_Entity_Name (N) + and then Is_Overloadable (Entity (N)) + then + return False; + + elsif Is_Atomic (Etype (N)) or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N))) then return True; @@ -5797,6 +5910,54 @@ package body Sem_Util is and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; + ----------------- + -- Is_Delegate -- + ----------------- + + function Is_Delegate (T : Entity_Id) return Boolean is + Desig_Type : Entity_Id; + + begin + if VM_Target /= CLI_Target then + return False; + end if; + + -- Access-to-subprograms are delegates in CIL + + if Ekind (T) = E_Access_Subprogram_Type then + return True; + end if; + + if Ekind (T) not in Access_Kind then + + -- A delegate is a managed pointer. If no designated type is defined + -- it means that it's not a delegate. + + return False; + end if; + + Desig_Type := Etype (Directly_Designated_Type (T)); + + if not Is_Tagged_Type (Desig_Type) then + return False; + end if; + + -- Test if the type is inherited from [mscorlib]System.Delegate + + while Etype (Desig_Type) /= Desig_Type loop + if Chars (Scope (Desig_Type)) /= No_Name + and then Is_Imported (Scope (Desig_Type)) + and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" + then + return True; + end if; + + Desig_Type := Etype (Desig_Type); + end loop; + + return False; + end Is_Delegate; + ---------------------------------------------- -- Is_Dependent_Component_Of_Mutable_Object -- ---------------------------------------------- @@ -6376,10 +6537,7 @@ package body Sem_Util is Ent : constant Entity_Id := Entity (Expr); Sub : constant Entity_Id := Enclosing_Subprogram (Ent); begin - if Ekind (Ent) /= E_Variable - and then - Ekind (Ent) /= E_In_Out_Parameter - then + if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then return False; else return Present (Sub) and then Sub = Current_Subprogram; @@ -7033,6 +7191,15 @@ package body Sem_Util is return (U /= 0); end Is_True; + ------------------------------- + -- Is_Universal_Numeric_Type -- + ------------------------------- + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is + begin + return T = Universal_Integer or else T = Universal_Real; + end Is_Universal_Numeric_Type; + ------------------- -- Is_Value_Type -- ------------------- @@ -7051,60 +7218,21 @@ package body Sem_Util is function Is_VMS_Operator (Op : Entity_Id) return Boolean is begin + -- The VMS operators are declared in a child of System that is loaded + -- through pragma Extend_System. In some rare cases a program is run + -- with this extension but without indicating that the target is VMS. + return Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) - and then Scope (Op) = System_Aux_Id; + and then + ((Present_System_Aux + and then Scope (Op) = System_Aux_Id) + or else + (True_VMS_Target + and then Scope (Scope (Op)) = RTU_Entity (System))); end Is_VMS_Operator; ----------------- - -- Is_Delegate -- - ----------------- - - function Is_Delegate (T : Entity_Id) return Boolean is - Desig_Type : Entity_Id; - - begin - if VM_Target /= CLI_Target then - return False; - end if; - - -- Access-to-subprograms are delegates in CIL - - if Ekind (T) = E_Access_Subprogram_Type then - return True; - end if; - - if Ekind (T) not in Access_Kind then - - -- A delegate is a managed pointer. If no designated type is defined - -- it means that it's not a delegate. - - return False; - end if; - - Desig_Type := Etype (Directly_Designated_Type (T)); - - if not Is_Tagged_Type (Desig_Type) then - return False; - end if; - - -- Test if the type is inherited from [mscorlib]System.Delegate - - while Etype (Desig_Type) /= Desig_Type loop - if Chars (Scope (Desig_Type)) /= No_Name - and then Is_Imported (Scope (Desig_Type)) - and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate" - then - return True; - end if; - - Desig_Type := Etype (Desig_Type); - end loop; - - return False; - end Is_Delegate; - - ----------------- -- Is_Variable -- ----------------- @@ -7118,14 +7246,14 @@ package body Sem_Util is -- expansion. function In_Protected_Function (E : Entity_Id) return Boolean; - -- Within a protected function, the private components of the - -- enclosing protected type are constants. A function nested within - -- a (protected) procedure is not itself protected. + -- Within a protected function, the private components of the enclosing + -- protected type are constants. A function nested within a (protected) + -- procedure is not itself protected. function Is_Variable_Prefix (P : Node_Id) return Boolean; - -- Prefixes can involve implicit dereferences, in which case we - -- must test for the case of a reference of a constant access - -- type, which can never be a variable. + -- Prefixes can involve implicit dereferences, in which case we must + -- test for the case of a reference of a constant access type, which can + -- can never be a variable. --------------------------- -- In_Protected_Function -- @@ -7141,9 +7269,7 @@ package body Sem_Util is else S := Current_Scope; while Present (S) and then S /= Prot loop - if Ekind (S) = E_Function - and then Scope (S) = Prot - then + if Ekind (S) = E_Function and then Scope (S) = Prot then return True; end if; @@ -7188,16 +7314,16 @@ package body Sem_Util is if Nkind (N) in N_Subexpr and then Assignment_OK (N) then return True; - -- Normally we go to the original node, but there is one exception - -- where we use the rewritten node, namely when it is an explicit - -- dereference. The generated code may rewrite a prefix which is an - -- access type with an explicit dereference. The dereference is a - -- variable, even though the original node may not be (since it could - -- be a constant of the access type). + -- Normally we go to the original node, but there is one exception where + -- we use the rewritten node, namely when it is an explicit dereference. + -- The generated code may rewrite a prefix which is an access type with + -- an explicit dereference. The dereference is a variable, even though + -- the original node may not be (since it could be a constant of the + -- access type). - -- In Ada 2005 we have a further case to consider: the prefix may be - -- a function call given in prefix notation. The original node appears - -- to be a selected component, but we need to examine the call. + -- In Ada 2005 we have a further case to consider: the prefix may be a + -- function call given in prefix notation. The original node appears to + -- be a selected component, but we need to examine the call. elsif Nkind (N) = N_Explicit_Dereference and then Nkind (Orig_Node) /= N_Explicit_Dereference @@ -7816,6 +7942,17 @@ package body Sem_Util is if Nkind (N) = N_Allocator then if Is_Dynamic then Set_Is_Dynamic_Coextension (N); + + -- If the allocator expression is potentially dynamic, it may + -- be expanded out of order and require dynamic allocation + -- anyway, so we treat the coextension itself as dynamic. + -- Potential optimization ??? + + elsif Nkind (Expression (N)) = N_Qualified_Expression + and then Nkind (Expression (Expression (N))) = N_Op_Concat + then + Set_Is_Dynamic_Coextension (N); + else Set_Is_Static_Coextension (N); end if; @@ -8658,9 +8795,7 @@ package body Sem_Util is -- If a record subtype is simply copied, the entity list will be -- shared. Thus cloned_Subtype must be set to indicate the sharing. - if Ekind (Old_Itype) = E_Record_Subtype - or else Ekind (Old_Itype) = E_Class_Wide_Subtype - then + if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then Set_Cloned_Subtype (New_Itype, Old_Itype); end if; @@ -8863,8 +8998,7 @@ package body Sem_Util is Sloc_Value : Source_Ptr; Id_Char : Character) return Entity_Id is - N : constant Entity_Id := - Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char)); + N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char); begin Set_Ekind (N, Kind); @@ -9479,15 +9613,112 @@ package body Sem_Util is then return Object_Access_Level (Expression (Obj)); - -- Function results are objects, so we get either the access level of - -- the function or, in the case of an indirect call, the level of the - -- access-to-subprogram type. - elsif Nkind (Obj) = N_Function_Call then - if Is_Entity_Name (Name (Obj)) then - return Subprogram_Access_Level (Entity (Name (Obj))); + + -- Function results are objects, so we get either the access level of + -- the function or, in the case of an indirect call, the level of the + -- access-to-subprogram type. (This code is used for Ada 95, but it + -- looks wrong, because it seems that we should be checking the level + -- of the call itself, even for Ada 95. However, using the Ada 2005 + -- version of the code causes regressions in several tests that are + -- compiled with -gnat95. ???) + + if Ada_Version < Ada_05 then + if Is_Entity_Name (Name (Obj)) then + return Subprogram_Access_Level (Entity (Name (Obj))); + else + return Type_Access_Level (Etype (Prefix (Name (Obj)))); + end if; + + -- For Ada 2005, the level of the result object of a function call is + -- defined to be the level of the call's innermost enclosing master. + -- We determine that by querying the depth of the innermost enclosing + -- dynamic scope. + else - return Type_Access_Level (Etype (Prefix (Name (Obj)))); + Return_Master_Scope_Depth_Of_Call : declare + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint; + -- Returns the scope depth of the given node's innermost + -- enclosing dynamic scope (effectively the accessibility + -- level of the innermost enclosing master). + + ---------------------------------- + -- Innermost_Master_Scope_Depth -- + ---------------------------------- + + function Innermost_Master_Scope_Depth + (N : Node_Id) return Uint + is + Node_Par : Node_Id := Parent (N); + + begin + -- Locate the nearest enclosing node (by traversing Parents) + -- that Defining_Entity can be applied to, and return the + -- depth of that entity's nearest enclosing dynamic scope. + + while Present (Node_Par) loop + case Nkind (Node_Par) is + when N_Component_Declaration | + N_Entry_Declaration | + N_Formal_Object_Declaration | + N_Formal_Type_Declaration | + N_Full_Type_Declaration | + N_Incomplete_Type_Declaration | + N_Loop_Parameter_Specification | + N_Object_Declaration | + N_Protected_Type_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Subtype_Declaration | + N_Function_Specification | + N_Procedure_Specification | + N_Task_Type_Declaration | + N_Body_Stub | + N_Generic_Instantiation | + N_Proper_Body | + N_Implicit_Label_Declaration | + N_Package_Declaration | + N_Single_Task_Declaration | + N_Subprogram_Declaration | + N_Generic_Declaration | + N_Renaming_Declaration | + N_Block_Statement | + N_Formal_Subprogram_Declaration | + N_Abstract_Subprogram_Declaration | + N_Entry_Body | + N_Exception_Declaration | + N_Formal_Package_Declaration | + N_Number_Declaration | + N_Package_Specification | + N_Parameter_Specification | + N_Single_Protected_Declaration | + N_Subunit => + + return Scope_Depth + (Nearest_Dynamic_Scope + (Defining_Entity (Node_Par))); + + when others => + null; + end case; + + Node_Par := Parent (Node_Par); + end loop; + + pragma Assert (False); + + -- Should never reach the following return + + return Scope_Depth (Current_Scope) + 1; + end Innermost_Master_Scope_Depth; + + -- Start of processing for Return_Master_Scope_Depth_Of_Call + + begin + return Innermost_Master_Scope_Depth (Obj); + end Return_Master_Scope_Depth_Of_Call; end if; -- For convenience we handle qualified expressions, even though @@ -10151,12 +10382,7 @@ package body Sem_Util is while R_Scope /= Standard_Standard loop exit when R_Scope = E_Scope; - if Ekind (R_Scope) /= E_Package - and then - Ekind (R_Scope) /= E_Block - and then - Ekind (R_Scope) /= E_Loop - then + if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then return False; else R_Scope := Scope (R_Scope); @@ -10352,6 +10578,32 @@ package body Sem_Util is end if; end Same_Value; + ----------------- + -- Save_Actual -- + ----------------- + + procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is + begin + if Is_Entity_Name (N) + or else + Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice) + or else + (Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Access) + + then + -- We are only interested in IN OUT parameters of inner calls + + if not Writable + or else Nkind (Parent (N)) = N_Function_Call + or else Nkind (Parent (N)) in N_Op + then + Actuals_In_Call.Increment_Last; + Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable); + end if; + end if; + end Save_Actual; + ------------------------ -- Scope_Is_Transient -- ------------------------ @@ -10978,22 +11230,6 @@ package body Sem_Util is return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; - -------------------- - -- Ultimate_Alias -- - -------------------- - -- To do: add occurrences calling this new subprogram - - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is - E : Entity_Id := Prim; - - begin - while Present (Alias (E)) loop - E := Alias (E); - end loop; - - return E; - end Ultimate_Alias; - -------------------------- -- Unit_Declaration_Node -- -------------------------- @@ -11232,8 +11468,10 @@ package body Sem_Util is and then Covers (Designated_Type (Expec_Type), Designated_Type (Found_Type)) then - Error_Msg_N ("result must be general access type!", Expr); - Error_Msg_NE ("add ALL to }!", Expr, Expec_Type); + Error_Msg_N -- CODEFIX + ("result must be general access type!", Expr); + Error_Msg_NE -- CODEFIX + ("add ALL to }!", Expr, Expec_Type); -- Another special check, if the expected type is an integer type, -- but the expression is of type System.Address, and the parent is @@ -11280,7 +11518,8 @@ package body Sem_Util is if From_With_Type (Found_Type) then Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_Qual_Level := 99; - Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type)); + Error_Msg_NE -- CODEFIX + ("\\missing `WITH &;", Expr, Scope (Found_Type)); Error_Msg_Qual_Level := 0; else Error_Msg_NE ("found}!", Expr, Found_Type); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9e743578829..54878f326a1 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -132,15 +132,20 @@ package Sem_Util is -- Check wrong use of dynamically tagged expression procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); - -- Verify that the full declaration of type T has been seen. If not, - -- place error message on node N. Used in object declarations, type - -- conversions, qualified expressions. + -- Verify that the full declaration of type T has been seen. If not, place + -- error message on node N. Used in object declarations, type conversions + -- and qualified expressions. procedure Check_Nested_Access (Ent : Entity_Id); -- Check whether Ent denotes an entity declared in an uplevel scope, which -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag -- accordingly. This is currently only enabled for VM_Target /= No_VM. + procedure Check_Order_Dependence; + -- Examine the actuals in a top-level call to determine whether aliasing + -- between two actuals, one of which is writable, can make the call + -- order-dependent. + procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. @@ -153,10 +158,10 @@ package Sem_Util is -- a possible unlocked access to data. procedure Check_VMS (Construct : Node_Id); - -- Check that this the target is OpenVMS, and if so, return with - -- no effect, otherwise post an error noting this can only be used - -- with OpenVMS ports. The argument is the construct in question - -- and is used to post the error message. + -- Check that this the target is OpenVMS, and if so, return with no effect, + -- otherwise post an error noting this can only be used with OpenVMS ports. + -- The argument is the construct in question and is used to post the error + -- message. procedure Collect_Interfaces (T : Entity_Id; @@ -187,10 +192,10 @@ package Sem_Util is -- information on the same interface type. function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; - -- Called upon type derivation and extension. We scan the declarative - -- part in which the type appears, and collect subprograms that have - -- one subsidiary subtype of the type. These subprograms can only - -- appear after the type itself. + -- Called upon type derivation and extension. We scan the declarative part + -- in which the type appears, and collect subprograms that have one + -- subsidiary subtype of the type. These subprograms can only appear after + -- the type itself. function Compile_Time_Constraint_Error (N : Node_Id; @@ -202,12 +207,11 @@ package Sem_Util is -- generates a warning (or error) message in the same manner, but it does -- not replace any nodes. For convenience, the function always returns its -- first argument. The message is a warning if the message ends with ?, or - -- we are operating in Ada 83 mode, or if the Warn parameter is set to - -- True. + -- we are operating in Ada 83 mode, or the Warn parameter is set to True. procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id); - -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag - -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false); + -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag of + -- Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false). function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id; -- Utility to create a parameter profile for a new subprogram spec, when @@ -216,6 +220,7 @@ package Sem_Util is -- for stubbed subprograms. function Current_Entity (N : Node_Id) return Entity_Id; + pragma Inline (Current_Entity); -- Find the currently visible definition for a given identifier, that is to -- say the first entry in the visibility chain for the Chars of N. @@ -235,21 +240,20 @@ package Sem_Util is -- from a library package which is not within any subprogram. function Defining_Entity (N : Node_Id) return Entity_Id; - -- Given a declaration N, returns the associated defining entity. If - -- the declaration has a specification, the entity is obtained from - -- the specification. If the declaration has a defining unit name, - -- then the defining entity is obtained from the defining unit name - -- ignoring any child unit prefixes. + -- Given a declaration N, returns the associated defining entity. If the + -- declaration has a specification, the entity is obtained from the + -- specification. If the declaration has a defining unit name, then the + -- defining entity is obtained from the defining unit name ignoring any + -- child unit prefixes. function Denotes_Discriminant (N : Node_Id; Check_Concurrent : Boolean := False) return Boolean; - -- Returns True if node N is an Entity_Name node for a discriminant. - -- If the flag Check_Concurrent is true, function also returns true - -- when N denotes the discriminal of the discriminant of a concurrent - -- type. This is necessary to disable some optimizations on private - -- components of protected types, and constraint checks on entry - -- families constrained by discriminants. + -- Returns True if node N is an Entity_Name node for a discriminant. If the + -- flag Check_Concurrent is true, function also returns true when N denotes + -- the discriminal of the discriminant of a concurrent type. This is needed + -- to disable some optimizations on private components of protected types, + -- and constraint checks on entry families constrained by discriminants. function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean; function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean; @@ -271,49 +275,48 @@ package Sem_Util is function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean; - -- Return true if Name1 and Name2 designate the same unit name; - -- each of these names is supposed to be a selected component name, - -- an expanded name, a defining program unit name or an identifier + -- Return true if Name1 and Name2 designate the same unit name; each of + -- these names is supposed to be a selected component name, an expanded + -- name, a defining program unit name or an identifier. function Enclosing_Generic_Body (N : Node_Id) return Node_Id; - -- Returns the Node_Id associated with the innermost enclosing - -- generic body, if any. If none, then returns Empty. + -- Returns the Node_Id associated with the innermost enclosing generic + -- body, if any. If none, then returns Empty. function Enclosing_Generic_Unit (N : Node_Id) return Node_Id; - -- Returns the Node_Id associated with the innermost enclosing - -- generic unit, if any. If none, then returns Empty. + -- Returns the Node_Id associated with the innermost enclosing generic + -- unit, if any. If none, then returns Empty. function Enclosing_Lib_Unit_Entity return Entity_Id; -- Returns the entity of enclosing N_Compilation_Unit Node which is the - -- root of the current scope (which must not be Standard_Standard, and - -- the caller is responsible for ensuring this condition). + -- root of the current scope (which must not be Standard_Standard, and the + -- caller is responsible for ensuring this condition). function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id; - -- Returns the enclosing N_Compilation_Unit Node that is the root - -- of a subtree containing N. + -- Returns the enclosing N_Compilation_Unit Node that is the root of a + -- subtree containing N. function Enclosing_Subprogram (E : Entity_Id) return Entity_Id; -- Utility function to return the Ada entity of the subprogram enclosing -- the entity E, if any. Returns Empty if no enclosing subprogram. procedure Ensure_Freeze_Node (E : Entity_Id); - -- Make sure a freeze node is allocated for entity E. If necessary, - -- build and initialize a new freeze node and set Has_Delayed_Freeze - -- true for entity E. + -- Make sure a freeze node is allocated for entity E. If necessary, build + -- and initialize a new freeze node and set Has_Delayed_Freeze True for E. procedure Enter_Name (Def_Id : Entity_Id); -- Insert new name in symbol table of current scope with check for - -- duplications (error message is issued if a conflict is found) - -- Note: Enter_Name is not used for overloadable entities, instead - -- these are entered using Sem_Ch6.Enter_Overloadable_Entity. + -- duplications (error message is issued if a conflict is found). + -- Note: Enter_Name is not used for overloadable entities, instead these + -- are entered using Sem_Ch6.Enter_Overloadable_Entity. procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id); - -- This procedure is called after issuing a message complaining - -- about an inappropriate use of limited type T. If useful, it - -- adds additional continuation lines to the message explaining - -- why type T is limited. Messages are placed at node N. + -- This procedure is called after issuing a message complaining about an + -- inappropriate use of limited type T. If useful, it adds additional + -- continuation lines to the message explaining why type T is limited. + -- Messages are placed at node N. procedure Find_Actual (N : Node_Id; @@ -329,11 +332,11 @@ package Sem_Util is function Find_Corresponding_Discriminant (Id : Node_Id; Typ : Entity_Id) return Entity_Id; - -- Because discriminants may have different names in a generic unit - -- and in an instance, they are resolved positionally when possible. - -- A reference to a discriminant carries the discriminant that it - -- denotes when analyzed. Subsequent uses of this id on a different - -- type denote the discriminant at the same position in this new type. + -- Because discriminants may have different names in a generic unit and in + -- an instance, they are resolved positionally when possible. A reference + -- to a discriminant carries the discriminant that it denotes when it is + -- analyzed. Subsequent uses of this id on a different type denotes the + -- discriminant at the same position in this new type. procedure Find_Overlaid_Entity (N : Node_Id; @@ -355,6 +358,12 @@ package Sem_Util is -- Determine the alternative chosen, so that the code of non-selected -- alternatives, and the warnings that may apply to them, are removed. + function Find_Body_Discriminal + (Spec_Discriminant : Entity_Id) return Entity_Id; + -- Given a discriminant of the record type that implements a task or + -- protected type, return the discriminal of the corresponding discriminant + -- of the actual concurrent type. + function First_Actual (Node : Node_Id) return Node_Id; -- Node is an N_Function_Call or N_Procedure_Call_Statement node. The -- result returned is the first actual parameter in declaration order @@ -364,7 +373,7 @@ package Sem_Util is -- iterating through the actuals in declaration order is to use this -- function to find the first actual, and then use Next_Actual to obtain -- the next actual in declaration order. Note that the value returned - -- is always the expression (not the N_Parameter_Association nodes + -- is always the expression (not the N_Parameter_Association nodes, -- even if named association is used). function Full_Qualified_Name (E : Entity_Id) return String_Id; @@ -409,15 +418,15 @@ package Sem_Util is function Get_Actual_Subtype (N : Node_Id) return Entity_Id; -- Given a node for an expression, obtain the actual subtype of the -- expression. In the case of a parameter where the formal is an - -- unconstrained array or discriminated type, this will be the - -- previously constructed subtype of the actual. Note that this is - -- not quite the "Actual Subtype" of the RM, since it is always - -- a constrained type, i.e. it is the subtype of the value of the - -- actual. The actual subtype is also returned in other cases where - -- it has already been constructed for an object. Otherwise the - -- expression type is returned unchanged, except for the case of an - -- unconstrained array type, where an actual subtype is created, using - -- Insert_Actions if necessary to insert any associated actions. + -- unconstrained array or discriminated type, this will be the previously + -- constructed subtype of the actual. Note that this is not quite the + -- "Actual Subtype" of the RM, since it is always a constrained type, i.e. + -- it is the subtype of the value of the actual. The actual subtype is also + -- returned in other cases where it has already been constructed for an + -- object. Otherwise the expression type is returned unchanged, except for + -- the case of an unconstrained array type, where an actual subtype is + -- created, using Insert_Actions if necessary to insert any associated + -- actions. function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id; -- This is like Get_Actual_Subtype, except that it never constructs an @@ -427,41 +436,40 @@ package Sem_Util is function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id; -- This is used to construct the string literal node representing a - -- default external name, i.e. one that is constructed from the name - -- of an entity, or (in the case of extended DEC import/export pragmas, - -- an identifier provided as the external name. Letters in the name are + -- default external name, i.e. one that is constructed from the name of an + -- entity, or (in the case of extended DEC import/export pragmas, an + -- identifier provided as the external name. Letters in the name are -- according to the setting of Opt.External_Name_Default_Casing. function Get_Generic_Entity (N : Node_Id) return Entity_Id; - -- Returns the true generic entity in an instantiation. If the name in - -- the instantiation is a renaming, the function returns the renamed - -- generic. + -- Returns the true generic entity in an instantiation. If the name in the + -- instantiation is a renaming, the function returns the renamed generic. procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id); - -- This procedure assigns to L and H respectively the values of the - -- low and high bounds of node N, which must be a range, subtype - -- indication, or the name of a scalar subtype. The result in L, H - -- may be set to Error if there was an earlier error in the range. + -- This procedure assigns to L and H respectively the values of the low and + -- high bounds of node N, which must be a range, subtype indication, or the + -- name of a scalar subtype. The result in L, H may be set to Error if + -- there was an earlier error in the range. function Get_Enum_Lit_From_Pos (T : Entity_Id; Pos : Uint; Loc : Source_Ptr) return Entity_Id; - -- This function obtains the E_Enumeration_Literal entity for the - -- specified value from the enumeration type or subtype T. The - -- second argument is the Pos value, which is assumed to be in range. - -- The third argument supplies a source location for constructed - -- nodes returned by this function. + -- This function obtains the E_Enumeration_Literal entity for the specified + -- value from the enumeration type or subtype T. The second argument is the + -- Pos value, which is assumed to be in range. The third argument supplies + -- a source location for constructed nodes returned by this function. procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id); -- Retrieve the fully expanded name of the library unit declared by -- Decl_Node into the name buffer. function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; + pragma Inline (Get_Name_Entity_Id); -- An entity value is associated with each name in the name table. The - -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, - -- which is the innermost visible entity with the given name. See the - -- body of Sem_Ch8 for further details on handling of entity visibility. + -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, which + -- is the innermost visible entity with the given name. See the body of + -- Sem_Ch8 for further details on handling of entity visibility. function Get_Pragma_Id (N : Node_Id) return Pragma_Id; pragma Inline (Get_Pragma_Id); @@ -479,22 +487,20 @@ package Sem_Util is -- with any other kind of entity. function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; - -- Nod is either a procedure call statement, or a function call, or - -- an accept statement node. This procedure finds the Entity_Id of the - -- related subprogram or entry and returns it, or if no subprogram can - -- be found, returns Empty. + -- Nod is either a procedure call statement, or a function call, or an + -- accept statement node. This procedure finds the Entity_Id of the related + -- subprogram or entry and returns it, or if no subprogram can be found, + -- returns Empty. function Get_Subprogram_Body (E : Entity_Id) return Node_Id; - -- Given the entity for a subprogram (E_Function or E_Procedure), - -- return the corresponding N_Subprogram_Body node. If the corresponding - -- body of the declaration is missing (as for an imported subprogram) - -- return Empty. + -- Given the entity for a subprogram (E_Function or E_Procedure), return + -- the corresponding N_Subprogram_Body node. If the corresponding body + -- is missing (as for an imported subprogram), return Empty. function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id; pragma Inline (Get_Task_Body_Procedure); -- Given an entity for a task type or subtype, retrieves the - -- Task_Body_Procedure field from the corresponding task type - -- declaration. + -- Task_Body_Procedure field from the corresponding task type declaration. function Has_Access_Values (T : Entity_Id) return Boolean; -- Returns true if type or subtype T is an access type, or has a component @@ -524,18 +530,18 @@ package Sem_Util is -- -- Note: Known_Incompatible does not mean that at run time the alignment -- of Expr is known to be wrong for Obj, just that it can be determined - -- that alignments have been explicitly or implicitly specified which - -- are incompatible (whereas Unknown means that even this is not known). - -- The appropriate reaction of a caller to Known_Incompatible is to treat - -- it as Unknown, but issue a warning that there may be an alignment error. + -- that alignments have been explicitly or implicitly specified which are + -- incompatible (whereas Unknown means that even this is not known). The + -- appropriate reaction of a caller to Known_Incompatible is to treat it as + -- Unknown, but issue a warning that there may be an alignment error. function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations function Has_Discriminant_Dependent_Constraint (Comp : Entity_Id) return Boolean; - -- Returns True if and only if Comp has a constrained subtype - -- that depends on a discriminant. + -- Returns True if and only if Comp has a constrained subtype that depends + -- on a discriminant. function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes @@ -565,18 +571,18 @@ package Sem_Util is -- yet received a full declaration. function Has_Stream (T : Entity_Id) return Boolean; - -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or - -- in the case of a composite type, has a component for which this - -- predicate is True, and if so returns True. Otherwise a result of - -- False means that there is no Stream type in sight. For a private - -- type, the test is applied to the underlying type (or returns False - -- if there is no underlying type). + -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or in the + -- case of a composite type, has a component for which this predicate is + -- True, and if so returns True. Otherwise a result of False means that + -- there is no Stream type in sight. For a private type, the test is + -- applied to the underlying type (or returns False if there is no + -- underlying type). function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Returns True if Typ is a composite type (array or record) which is -- either itself a tagged type, or has a component (recursively) which is -- a tagged type. Returns False for non-composite type, or if no tagged - -- component is present. This function is used to check if '=' has to be + -- component is present. This function is used to check if "=" has to be -- expanded into a bunch component comparisons. function Implements_Interface @@ -607,11 +613,11 @@ package Sem_Util is -- Returns True if node N belongs to a parameter specification function In_Subprogram_Or_Concurrent_Unit return Boolean; - -- Determines if the current scope is within a subprogram compilation - -- unit (inside a subprogram declaration, subprogram body, or generic - -- subprogram declaration) or within a task or protected body. The test - -- is for appearing anywhere within such a construct (that is it does not - -- need to be directly within). + -- Determines if the current scope is within a subprogram compilation unit + -- (inside a subprogram declaration, subprogram body, or generic + -- subprogram declaration) or within a task or protected body. The test is + -- for appearing anywhere within such a construct (that is it does not need + -- to be directly within). function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; -- Determine whether a declaration occurs within the visible part of a @@ -643,8 +649,8 @@ package Sem_Util is -- Determines if N is an actual parameter in a subprogram call function Is_Aliased_View (Obj : Node_Id) return Boolean; - -- Determine if Obj is an aliased view, i.e. the name of an - -- object to which 'Access or 'Unchecked_Access can apply. + -- Determine if Obj is an aliased view, i.e. the name of an object to which + -- 'Access or 'Unchecked_Access can apply. function Is_Ancestor_Package (E1 : Entity_Id; @@ -652,8 +658,8 @@ package Sem_Util is -- Determine whether package E1 is an ancestor of E2 function Is_Atomic_Object (N : Node_Id) return Boolean; - -- Determines if the given node denotes an atomic object in the sense - -- of the legality checks described in RM C.6(12). + -- Determines if the given node denotes an atomic object in the sense of + -- the legality checks described in RM C.6(12). function Is_Coextension_Root (N : Node_Id) return Boolean; -- Determine whether node N is an allocator which acts as a coextension @@ -690,9 +696,10 @@ package Sem_Util is -- it is of protected, synchronized or task kind. function Is_False (U : Uint) return Boolean; - -- The argument is a Uint value which is the Boolean'Pos value of a - -- Boolean operand (i.e. is either 0 for False, or 1 for True). This - -- function simply tests if it is False (i.e. zero) + pragma Inline (Is_False); + -- The argument is a Uint value which is the Boolean'Pos value of a Boolean + -- operand (i.e. is either 0 for False, or 1 for True). This function tests + -- if it is False (i.e. zero). function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean; -- Returns True iff the number U is a model number of the fixed- @@ -712,7 +719,7 @@ package Sem_Util is -- by a derived type declarations. function Is_LHS (N : Node_Id) return Boolean; - -- Returns True iff N is used as Name in an assignment statement. + -- Returns True iff N is used as Name in an assignment statement function Is_Library_Level_Entity (E : Entity_Id) return Boolean; -- A library-level declaration is one that is accessible from Standard, @@ -728,11 +735,11 @@ package Sem_Util is -- variable and constant objects return True (compare Is_Variable). function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean; - -- Used to test if AV is an acceptable formal for an OUT or IN OUT - -- formal. Note that the Is_Variable function is not quite the right - -- test because this is a case in which conversions whose expression - -- is a variable (in the Is_Variable sense) with a non-tagged type - -- target are considered view conversions and hence variables. + -- Used to test if AV is an acceptable formal for an OUT or IN OUT formal. + -- Note that the Is_Variable function is not quite the right test because + -- this is a case in which conversions whose expression is a variable (in + -- the Is_Variable sense) with a non-tagged type target are considered view + -- conversions and hence variables. function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is partly @@ -776,6 +783,7 @@ package Sem_Util is -- normally such nodes represent a direct name. function Is_Statement (N : Node_Id) return Boolean; + pragma Inline (Is_Statement); -- Check if the node N is a statement node. Note that this includes -- the case of procedure call statements (unlike the direct use of -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). @@ -785,14 +793,19 @@ package Sem_Util is -- Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2)) function Is_Transfer (N : Node_Id) return Boolean; - -- Returns True if the node N is a statement which is known to cause - -- an unconditional transfer of control at runtime, i.e. the following + -- Returns True if the node N is a statement which is known to cause an + -- unconditional transfer of control at runtime, i.e. the following -- statement definitely will not be executed. function Is_True (U : Uint) return Boolean; - -- The argument is a Uint value which is the Boolean'Pos value of a - -- Boolean operand (i.e. is either 0 for False, or 1 for True). This - -- function simply tests if it is True (i.e. non-zero) + pragma Inline (Is_True); + -- The argument is a Uint value which is the Boolean'Pos value of a Boolean + -- operand (i.e. is either 0 for False, or 1 for True). This function tests + -- if it is True (i.e. non-zero). + + function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean; + pragma Inline (Is_Universal_Numeric_Type); + -- True if T is Universal_Integer or Universal_Real function Is_Value_Type (T : Entity_Id) return Boolean; -- Returns true if type T represents a value type. This is only relevant to @@ -994,7 +1007,8 @@ package Sem_Util is procedure Next_Actual (Actual_Id : in out Node_Id); pragma Inline (Next_Actual); - -- Next_Actual (N) is equivalent to N := Next_Actual (N) + -- Next_Actual (N) is equivalent to N := Next_Actual (N). Note that we + -- inline this procedural form, but not the functional form that follows. function Next_Actual (Actual_Id : Node_Id) return Node_Id; -- Find next actual parameter in declaration order. As described for @@ -1152,6 +1166,11 @@ package Sem_Util is -- are only partially ordered, so Scope_Within_Or_Same (A,B) and -- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B. + procedure Save_Actual (N : Node_Id; Writable : Boolean := False); + -- Enter an actual in a call in a table global, for subsequent check of + -- possible order dependence in the presence of IN OUT parameters for + -- functions in Ada 2012 (or access parameters in older language versions). + function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean; -- Like Scope_Within_Or_Same, except that this function returns -- False in the case where Scope1 and Scope2 are the same scope. @@ -1162,6 +1181,7 @@ package Sem_Util is -- foreign convention, then we set Can_Use_Internal_Rep to False on E. procedure Set_Current_Entity (E : Entity_Id); + pragma Inline (Set_Current_Entity); -- Establish the entity E as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name) @@ -1179,6 +1199,7 @@ package Sem_Util is -- can check identifier spelling style. procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id); + pragma Inline (Set_Name_Entity_Id); -- Sets the Entity_Id value associated with the given name, which is the -- Id of the innermost visible entity with the given name. See the body -- of package Sem_Ch8 for further details on the handling of visibility. @@ -1209,6 +1230,7 @@ package Sem_Util is -- Set the flag Is_Transient of the current scope procedure Set_Size_Info (T1, T2 : Entity_Id); + pragma Inline (Set_Size_Info); -- Copies the Esize field and Has_Biased_Representation flag from sub(type) -- entity T2 to (sub)type entity T1. Also copies the Is_Unsigned_Type flag -- in the fixed-point and discrete cases, and also copies the alignment @@ -1241,10 +1263,6 @@ package Sem_Util is function Type_Access_Level (Typ : Entity_Id) return Uint; -- Return the accessibility level of Typ - function Ultimate_Alias (Prim : Entity_Id) return Entity_Id; - -- Return the last entity in the chain of aliased entities of Prim. - -- If Prim has no alias return Prim. - function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a program unit, this function returns the -- corresponding xxx_Declaration node for the entity. Also applies to the @@ -1253,31 +1271,21 @@ package Sem_Util is -- may be a child unit with any number of ancestors. function Universal_Interpretation (Opnd : Node_Id) return Entity_Id; - -- Yields universal_Integer or Universal_Real if this is a candidate + -- Yields Universal_Integer or Universal_Real if this is a candidate function Unqualify (Expr : Node_Id) return Node_Id; - -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), - -- this returns X. If Expr is not a qualified expression, returns Expr. + pragma Inline (Unqualify); + -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), this + -- returns X. If Expr is not a qualified expression, returns Expr. function Within_Init_Proc return Boolean; -- Determines if Current_Scope is within an init proc procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id); - -- Output error message for incorrectly typed expression. Expr is the - -- node for the incorrectly typed construct (Etype (Expr) is the type - -- found), and Expected_Type is the entity for the expected type. Note - -- that Expr does not have to be a subexpression, anything with an - -- Etype field may be used. - -private - pragma Inline (Current_Entity); - pragma Inline (Get_Name_Entity_Id); - pragma Inline (Is_False); - pragma Inline (Is_Statement); - pragma Inline (Is_True); - pragma Inline (Set_Current_Entity); - pragma Inline (Set_Name_Entity_Id); - pragma Inline (Set_Size_Info); - pragma Inline (Unqualify); + -- Output error message for incorrectly typed expression. Expr is the node + -- for the incorrectly typed construct (Etype (Expr) is the type found), + -- and Expected_Type is the entity for the expected type. Note that Expr + -- does not have to be a subexpression, anything with an Etype field may + -- be used. end Sem_Util; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 841f5dd61cb..7f18a75e71e 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2010, 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- -- @@ -538,6 +538,29 @@ package body Sem_Warn is then return Abandon; end if; + + -- If any of the arguments are of type access to subprogram, then + -- we may have funny side effects, so no warning in this case. + + declare + Actual : Node_Id; + begin + Actual := First_Actual (N); + while Present (Actual) loop + if Is_Access_Subprogram_Type (Etype (Actual)) then + return Abandon; + else + Next_Actual (Actual); + end if; + end loop; + end; + + -- Declaration of the variable in question + + elsif Nkind (N) = N_Object_Declaration + and then Defining_Identifier (N) = Var + then + return Abandon; end if; -- All OK, continue scan @@ -554,24 +577,34 @@ package body Sem_Warn is return; end if; - -- Case of WHILE loop + -- Deal with Iteration scheme present declare Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); begin - if Present (Iter) and then Present (Condition (Iter)) then + if Present (Iter) then - -- Skip processing for while iteration with conditions actions, - -- since they make it too complicated to get the warning right. + -- While iteration - if Present (Condition_Actions (Iter)) then - return; - end if; + if Present (Condition (Iter)) then + + -- Skip processing for while iteration with conditions actions, + -- since they make it too complicated to get the warning right. + + if Present (Condition_Actions (Iter)) then + return; + end if; + + -- Capture WHILE condition + + Expression := Condition (Iter); - -- Capture WHILE condition + -- For iteration, do not process, since loop will always terminate - Expression := Condition (Iter); + elsif Present (Loop_Parameter_Specification (Iter)) then + return; + end if; end if; end; @@ -994,9 +1027,8 @@ package body Sem_Warn is -- we exclude protected types, too complicated to worry about. if Ekind (E1) = E_Variable - or else - ((Ekind (E1) = E_Out_Parameter - or else Ekind (E1) = E_In_Out_Parameter) + or else + (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) and then not Is_Protected_Type (Current_Scope)) then -- Case of an unassigned variable @@ -1312,7 +1344,7 @@ package body Sem_Warn is while Present (Comp) loop if Ekind (Comp) = E_Component and then Nkind (Parent (Comp)) = - N_Component_Declaration + N_Component_Declaration and then No (Expression (Parent (Comp))) then Error_Msg_Node_2 := Comp; @@ -1431,12 +1463,9 @@ package body Sem_Warn is -- a separate spec. and then not (Is_Formal (E1) - and then - Ekind (Scope (E1)) = E_Subprogram_Body - and then - Present (Spec_Entity (E1)) - and then - Referenced (Spec_Entity (E1))) + and then Ekind (Scope (E1)) = E_Subprogram_Body + and then Present (Spec_Entity (E1)) + and then Referenced (Spec_Entity (E1))) -- Consider private type referenced if full view is referenced. -- If there is not full view, this is a generic type on which @@ -1444,8 +1473,7 @@ package body Sem_Warn is and then not (Is_Private_Type (E1) - and then - Present (Full_View (E1)) + and then Present (Full_View (E1)) and then Referenced (Full_View (E1))) -- Don't worry about full view, only about private type @@ -1475,16 +1503,15 @@ package body Sem_Warn is -- be non-referenced, since they start up tasks! and then ((Ekind (E1) /= E_Variable - and then Ekind (E1) /= E_Constant - and then Ekind (E1) /= E_Component) - or else not Is_Task_Type (E1T)) + and then Ekind (E1) /= E_Constant + and then Ekind (E1) /= E_Component) + or else not Is_Task_Type (E1T)) -- For subunits, only place warnings on the main unit itself, -- since parent units are not completely compiled. and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit - or else - Get_Source_Unit (E1) = Main_Unit) + or else Get_Source_Unit (E1) = Main_Unit) -- No warning on a return object, because these are often -- created with a single expression and an implicit return. @@ -1499,9 +1526,8 @@ package body Sem_Warn is -- since they refer to problems in internal units). if GNAT_Mode - or else not - Is_Internal_File_Name - (Unit_File_Name (Get_Source_Unit (E1))) + or else not Is_Internal_File_Name + (Unit_File_Name (Get_Source_Unit (E1))) then -- We do not immediately flag the error. This is because we -- have not expanded generic bodies yet, and they may have @@ -2071,7 +2097,7 @@ package body Sem_Warn is while Present (Nam) loop if Entity (Nam) = Pack then Error_Msg_Qual_Level := 1; - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?no entities of package& are referenced!", Nam, Pack); Error_Msg_Qual_Level := 0; @@ -2268,7 +2294,7 @@ package body Sem_Warn is -- else or a pragma elaborate with a body library task). elsif Has_Visible_Entities (Entity (Name (Item))) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?unit& is not referenced!", Name (Item)); end if; end if; @@ -2345,7 +2371,7 @@ package body Sem_Warn is if not Has_Unreferenced (Entity (Name (Item))) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?no entities of & are referenced!", Name (Item)); end if; @@ -2361,7 +2387,7 @@ package body Sem_Warn is and then not Has_Warnings_Off (Lunit) and then not Has_Unreferenced (Pack) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?no entities of & are referenced!", Unit_Declaration_Node (Pack), Pack); @@ -2401,12 +2427,12 @@ package body Sem_Warn is end if; if Unreferenced_In_Spec (Item) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?unit& is not referenced in spec!", Name (Item)); elsif No_Entities_Ref_In_Spec (Item) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?no entities of & are referenced in spec!", Name (Item)); @@ -2755,8 +2781,9 @@ package body Sem_Warn is -- default mode. elsif Check_Unreferenced then - Error_Msg_N ("?formal parameter& is read but " - & "never assigned!", E1); + Error_Msg_N + ("?formal parameter& is read but " + & "never assigned!", E1); end if; end if; @@ -2850,9 +2877,7 @@ package body Sem_Warn is -- Reference to obsolescent component - elsif Ekind (E) = E_Component - or else Ekind (E) = E_Discriminant - then + elsif Ekind_In (E, E_Component, E_Discriminant) then Error_Msg_NE ("?reference to obsolescent component& declared#", N, E); @@ -3490,26 +3515,16 @@ package body Sem_Warn is and then Is_Known_Branch then declare - Start : Source_Ptr; - Dummy : Source_Ptr; - Typ : Character; Atrue : Boolean; begin - Sloc_Range (Orig, Start, Dummy); Atrue := Test_Result; if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then Atrue := not Atrue; end if; - if Atrue then - Typ := 't'; - else - Typ := 'f'; - end if; - - Set_SCO_Condition (Start, Typ); + Set_SCO_Condition (Orig, Atrue); end; end if; @@ -3841,7 +3856,8 @@ package body Sem_Warn is procedure Warn1 is begin Error_Msg_Uint_1 := Low_Bound; - Error_Msg_FE ("?index for& may assume lower bound of^", X, Ent); + Error_Msg_FE -- CODEFIX + ("?index for& may assume lower bound of^", X, Ent); end Warn1; -- Start of processing for Test_Suspicious_Index @@ -3865,11 +3881,11 @@ package body Sem_Warn is if Nkind (Original_Node (X)) = N_Integer_Literal then if Intval (X) = Low_Bound then - Error_Msg_FE -- CODEFIX + Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First`", X, Ent); else Error_Msg_Uint_1 := Intval (X) - Low_Bound; - Error_Msg_FE -- CODEFIX + Error_Msg_FE -- CODEFIX ("\suggested replacement: `&''First + ^`", X, Ent); end if; @@ -3975,7 +3991,7 @@ package body Sem_Warn is -- Replacement subscript is now in string buffer - Error_Msg_FE -- CODEFIX + Error_Msg_FE -- CODEFIX ("\suggested replacement: `&~`", Original_Node (X), Ent); end if; @@ -4147,10 +4163,10 @@ package body Sem_Warn is if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?renamed variable & is not referenced!", E); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("?variable & is not referenced!", E); end if; end if; @@ -4160,10 +4176,11 @@ package body Sem_Warn is if Present (Renamed_Object (E)) and then Comes_From_Source (Renamed_Object (E)) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("?renamed constant & is not referenced!", E); else - Error_Msg_N ("?constant & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?constant & is not referenced!", E); end if; when E_In_Parameter | @@ -4188,7 +4205,7 @@ package body Sem_Warn is end if; if not Is_Trivial_Subprogram (Scope (E)) then - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?formal parameter & is not referenced!", E, Spec_E); end if; @@ -4203,28 +4220,36 @@ package body Sem_Warn is when E_Named_Integer | E_Named_Real => - Error_Msg_N ("?named number & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?named number & is not referenced!", E); when Formal_Object_Kind => - Error_Msg_N ("?formal object & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?formal object & is not referenced!", E); when E_Enumeration_Literal => - Error_Msg_N ("?literal & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?literal & is not referenced!", E); when E_Function => - Error_Msg_N ("?function & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?function & is not referenced!", E); when E_Procedure => - Error_Msg_N ("?procedure & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?procedure & is not referenced!", E); when E_Package => - Error_Msg_N ("?package & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?package & is not referenced!", E); when E_Exception => - Error_Msg_N ("?exception & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?exception & is not referenced!", E); when E_Label => - Error_Msg_N ("?label & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?label & is not referenced!", E); when E_Generic_Procedure => Error_Msg_N -- CODEFIX @@ -4235,10 +4260,12 @@ package body Sem_Warn is ("?generic function & is never instantiated!", E); when Type_Kind => - Error_Msg_N ("?type & is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?type & is not referenced!", E); when others => - Error_Msg_N ("?& is not referenced!", E); + Error_Msg_N -- CODEFIX + ("?& is not referenced!", E); end case; -- Kill warnings on the entity on which the message has been posted @@ -4335,7 +4362,7 @@ package body Sem_Warn is ("?& modified by call, but value never referenced", Last_Assignment (Ent), Ent); else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?useless assignment to&, value never referenced!", Last_Assignment (Ent), Ent); end if; @@ -4351,7 +4378,7 @@ package body Sem_Warn is ("?& modified by call, but value overwritten #!", Last_Assignment (Ent), Ent); else - Error_Msg_NE + Error_Msg_NE -- CODEFIX ("?useless assignment to&, value overwritten #!", Last_Assignment (Ent), Ent); end if; diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb index dc6ab38d448..1d24ca227f3 100644 --- a/gcc/ada/sfn_scan.adb +++ b/gcc/ada/sfn_scan.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,11 +37,10 @@ package body SFN_Scan is -- Allow easy access to control character definitions EOF : constant Character := ASCII.SUB; - -- The character SUB (16#1A#) is used in DOS and other systems derived - -- from DOS (OS/2, NT etc.) to signal the end of a text file. If this - -- character appears as the last character of a file scanned by a call - -- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as - -- an illegal character. + -- The character SUB (16#1A#) is used in DOS-derived systems, such as + -- Windows to signal the end of a text file. If this character appears as + -- the last character of a file scanned by a call to Scan_SFN_Pragmas, then + -- it is ignored, otherwise it is treated as an illegal character. type String_Ptr is access String; @@ -637,7 +636,7 @@ package body SFN_Scan is loop if At_EOF or else S (P) = LF or else S (P) = CR then - Error -- CODEFIX + Error -- CODEFIX ("missing string quote"); elsif S (P) = HT then diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 57f8f93965d..c43e0b4cbe2 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -146,7 +146,9 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); return List1 (N); @@ -229,6 +231,7 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_In or else NT (N).Nkind = N_Not_In); @@ -791,6 +794,7 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant); return List4 (N); @@ -1169,6 +1173,8 @@ package body Sinfo is or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association @@ -1178,6 +1184,7 @@ package body Sinfo is or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition @@ -1555,6 +1562,14 @@ package body Sinfo is return Flag16 (N); end Interface_Present; + function Import_Interface_Present + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag16 (N); + end Import_Interface_Present; + function In_Present (N : Node_Id) return Boolean is begin @@ -1572,6 +1587,14 @@ package body Sinfo is return Flag11 (N); end Includes_Infinities; + function Inherited_Discriminant + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + return Flag13 (N); + end Inherited_Discriminant; + function Instance_Spec (N : Node_Id) return Node_Id is begin @@ -2569,26 +2592,12 @@ package body Sinfo is (N : Node_Id) return Node_Id is begin pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); + or else NT (N).Nkind = N_SCIL_Membership_Test); return Node4 (N); end SCIL_Entity; - function SCIL_Related_Node - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init - or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); - return Node1 (N); - end SCIL_Related_Node; - function SCIL_Tag_Value (N : Node_Id) return Node_Id is begin @@ -3049,7 +3058,9 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_And_Then + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Compilation_Unit_Aux + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Or_Else); Set_List1_With_Parent (N, Val); @@ -3132,6 +3143,7 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_In or else NT (N).Nkind = N_Not_In); @@ -3694,6 +3706,7 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant); Set_List4_With_Parent (N, Val); @@ -4063,6 +4076,8 @@ package body Sinfo is or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause + or else NT (N).Nkind = N_Case_Expression + or else NT (N).Nkind = N_Case_Expression_Alternative or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association @@ -4072,6 +4087,7 @@ package body Sinfo is or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration + or else NT (N).Nkind = N_Expression_With_Actions or else NT (N).Nkind = N_Free_Statement or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition @@ -4449,6 +4465,14 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Interface_Present; + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag16 (N, Val); + end Set_Import_Interface_Present; + procedure Set_In_Present (N : Node_Id; Val : Boolean := True) is begin @@ -4466,6 +4490,14 @@ package body Sinfo is Set_Flag11 (N, Val); end Set_Includes_Infinities; + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Component_Association); + Set_Flag13 (N, Val); + end Set_Inherited_Discriminant; + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id) is begin @@ -5463,26 +5495,12 @@ package body Sinfo is (N : Node_Id; Val : Node_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); + or else NT (N).Nkind = N_SCIL_Membership_Test); Set_Node4 (N, Val); -- semantic field, no parent set end Set_SCIL_Entity; - procedure Set_SCIL_Related_Node - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init - or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init - or else NT (N).Nkind = N_SCIL_Dispatching_Call - or else NT (N).Nkind = N_SCIL_Membership_Test - or else NT (N).Nkind = N_SCIL_Tag_Init); - Set_Node1 (N, Val); -- semantic field, no parent set - end Set_SCIL_Related_Node; - procedure Set_SCIL_Tag_Value (N : Node_Id; Val : Node_Id) is begin @@ -6014,7 +6032,6 @@ package body Sinfo is T = V8; end Nkind_In; - function Nkind_In (T : Node_Kind; V1 : Node_Kind; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 31f555b4050..cb358c4d75b 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -1172,6 +1172,11 @@ package Sinfo is -- 'Address or 'Tag attribute. ???There are other implicit with clauses -- as well. + -- Import_Interface_Present (Flag16-Sem) + -- This flag is set in an Interface or Import pragma if a matching + -- pragma of the other kind is also present. This is used to avoid + -- generating some unwanted error messages. + -- Includes_Infinities (Flag11-Sem) -- This flag is present in N_Range nodes. It is set for the range of -- unconstrained float types defined in Standard, which include not only @@ -1180,6 +1185,12 @@ package Sinfo is -- range is given by the programmer, even if that range is identical to -- the range for Float. + -- Inherited_Discriminant (Flag13-Sem) + -- This flag is present in N_Component_Association nodes. It indicates + -- that a given component association in an extension aggregate is the + -- value obtained from a constraint on an ancestor. Used to prevent + -- double expansion when the aggregate has expansion delayed. + -- Instance_Spec (Node5-Sem) -- This field is present in generic instantiation nodes, and also in -- formal package declaration nodes (formal package declarations are @@ -1615,10 +1626,6 @@ package Sinfo is -- Present in SCIL nodes. Used to reference the tagged type associated -- with the SCIL node. - -- SCIL_Related_Node (Node1-Sem) - -- Present in SCIL nodes. Used to reference a tree node that requires - -- special processing in the CodePeer backend. - -- SCIL_Controlling_Tag (Node5-Sem) -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the -- controlling tag of a dispatching call. @@ -1993,6 +2000,7 @@ package Sinfo is -- Pragma_Identifier (Node4) -- Next_Rep_Item (Node5-Sem) -- Pragma_Enabled (Flag5-Sem) + -- Import_Interface_Present (Flag16-Sem) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma @@ -3340,6 +3348,7 @@ package Sinfo is -- Loop_Actions (List2-Sem) -- Expression (Node3) -- Box_Present (Flag15) + -- Inherited_Discriminant (Flag13) -- Note: this structure is used for both record component associations -- and array component associations, since the two cases aren't always @@ -6530,10 +6539,46 @@ package Sinfo is -- reconstructed tree printed by Sprint, and the node descriptions here -- show this syntax. - -- Note: Conditional_Expression is in this section for historical reasons. - -- We will move it to its appropriate place when it is officially approved - -- as an extension (and then we will know what the exact grammar and place - -- in the Reference Manual is!) + -- Note: Case_Expression and Conditional_Expression is in this section for + -- now, since they are extensions. We will move them to their appropriate + -- places when they are officially approved as extensions (and then we will + -- know what the exact grammar and place in the Reference Manual is!) + + --------------------- + -- Case Expression -- + --------------------- + + -- CASE_EXPRESSION ::= + -- case EXPRESSION is + -- CASE_EXPRESSION_ALTERNATIVE + -- {CASE_EXPRESSION_ALTERNATIVE} + + -- Note that the Alternatives cannot include pragmas (this constrasts + -- with the situation of case statements where pragmas are allowed). + + -- N_Case_Expression + -- Sloc points to CASE + -- Expression (Node3) + -- Alternatives (List4) + + --------------------------------- + -- Case Expression Alternative -- + --------------------------------- + + -- CASE_STATEMENT_ALTERNATIVE ::= + -- when DISCRETE_CHOICE_LIST => + -- EXPRESSION + + -- N_Case_Expression_Alternative + -- Sloc points to WHEN + -- Actions (List1) + -- Discrete_Choices (List4) + -- Expression (Node3) + + -- Note: The Actions field temporarily holds any actions associated with + -- evaluation of the Expression. During expansion of the case expression + -- these actions are wrapped into the an N_Expressions_With_Actions node + -- replacing the original expression. ---------------------------- -- Conditional Expression -- @@ -6604,6 +6649,46 @@ package Sinfo is -- Has_Private_View (Flag11-Sem) set in generic units. -- plus fields for expression + ----------------------------- + -- Expression with Actions -- + ----------------------------- + + -- This node is created by the analyzer/expander to handle some + -- expansion cases, notably short circuit forms where there are + -- actions associated with the right hand operand. + + -- The N_Expression_With_Actions node represents an expression with + -- an associated set of actions (which are executable statements and + -- declarations, as might occur in a handled statement sequence). + + -- The required semantics is that the set of actions is executed in + -- the order in which it appears just before the expression is + -- evaluated (and these actions must only be executed if the value + -- of the expression is evaluated). The node is considered to be + -- a subexpression, whose value is the value of the Expression after + -- executing all the actions. + + -- Note: if the actions contain declarations, then these declarations + -- maybe referenced with in the expression. It is thus appropriate for + -- the back end to create a scope that encompasses the construct (any + -- declarations within the actions will definitely not be referenced + -- once elaboration of the construct is completed). + + -- Sprint syntax: do + -- action; + -- action; + -- ... + -- action; + -- in expression end + + -- N_Expression_With_Actions + -- Actions (List1) + -- Expression (Node3) + -- plus fields for expression + + -- Note: the actions list is always non-null, since we would + -- never have created this node if there weren't some actions. + -------------------- -- Free Statement -- -------------------- @@ -6904,34 +6989,21 @@ package Sinfo is -- Meanwhile these nodes should be considered in experimental form, and -- should be ignored by all code generating back ends. ??? - -- N_SCIL_Dispatch_Table_Object_Init - -- Sloc references a declaration node containing a dispatch table - -- SCIL_Related_Node (Node1-Sem) - -- SCIL_Entity (Node4-Sem) - -- N_SCIL_Dispatch_Table_Tag_Init -- Sloc references a node for a tag initialization - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Entity (Node4-Sem) -- N_SCIL_Dispatching_Call -- Sloc references the node of a dispatching call - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Target_Prim (Node2-Sem) -- SCIL_Entity (Node4-Sem) -- SCIL_Controlling_Tag (Node5-Sem) -- N_SCIL_Membership_Test -- Sloc references the node of a membership test - -- SCIL_Related_Node (Node1-Sem) -- SCIL_Tag_Value (Node5-Sem) -- SCIL_Entity (Node4-Sem) - -- N_SCIL_Tag_Init - -- Sloc references the node of a tag component initialization - -- SCIL_Related_Node (Node1-Sem) - -- SCIL_Entity (Node4-Sem) - --------------------- -- Subprogram_Info -- --------------------- @@ -7188,6 +7260,7 @@ package Sinfo is N_Conditional_Expression, N_Explicit_Dereference, + N_Expression_With_Actions, N_Function_Call, N_Indexed_Component, N_Integer_Literal, @@ -7205,6 +7278,7 @@ package Sinfo is N_Aggregate, N_Allocator, + N_Case_Expression, N_Extension_Aggregate, N_Range, N_Real_Literal, @@ -7371,11 +7445,9 @@ package Sinfo is -- SCIL nodes - N_SCIL_Dispatch_Table_Object_Init, N_SCIL_Dispatch_Table_Tag_Init, N_SCIL_Dispatching_Call, N_SCIL_Membership_Test, - N_SCIL_Tag_Init, -- Other nodes (not part of any subtype class) @@ -7383,6 +7455,7 @@ package Sinfo is N_Abstract_Subprogram_Declaration, N_Access_Definition, N_Access_To_Object_Definition, + N_Case_Expression_Alternative, N_Case_Statement_Alternative, N_Compilation_Unit, N_Compilation_Unit_Aux, @@ -7588,8 +7661,8 @@ package Sinfo is N_Or_Else; subtype N_SCIL_Node is Node_Kind range - N_SCIL_Dispatch_Table_Object_Init .. - N_SCIL_Tag_Init; + N_SCIL_Dispatch_Table_Tag_Init .. + N_SCIL_Membership_Test; subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range N_Abort_Statement .. @@ -8111,12 +8184,18 @@ package Sinfo is function Implicit_With (N : Node_Id) return Boolean; -- Flag16 + function Import_Interface_Present + (N : Node_Id) return Boolean; -- Flag16 + function In_Present (N : Node_Id) return Boolean; -- Flag15 function Includes_Infinities (N : Node_Id) return Boolean; -- Flag11 + function Inherited_Discriminant + (N : Node_Id) return Boolean; -- Flag13 + function Instance_Spec (N : Node_Id) return Node_Id; -- Node5 @@ -8435,9 +8514,6 @@ package Sinfo is function SCIL_Entity (N : Node_Id) return Node_Id; -- Node4 - function SCIL_Related_Node - (N : Node_Id) return Node_Id; -- Node1 - function SCIL_Tag_Value (N : Node_Id) return Node_Id; -- Node5 @@ -9035,12 +9111,18 @@ package Sinfo is procedure Set_Implicit_With (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Import_Interface_Present + (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_In_Present (N : Node_Id; Val : Boolean := True); -- Flag15 procedure Set_Includes_Infinities (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Inherited_Discriminant + (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Instance_Spec (N : Node_Id; Val : Node_Id); -- Node5 @@ -9359,9 +9441,6 @@ package Sinfo is procedure Set_SCIL_Entity (N : Node_Id; Val : Node_Id); -- Node4 - procedure Set_SCIL_Related_Node - (N : Node_Id; Val : Node_Id); -- Node1 - procedure Set_SCIL_Tag_Value (N : Node_Id; Val : Node_Id); -- Node5 @@ -10194,6 +10273,20 @@ package Sinfo is 4 => False, -- unused 5 => False), -- unused + N_Case_Expression => + (1 => False, -- unused + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => True, -- Alternatives (List4) + 5 => False), -- unused + + N_Case_Expression_Alternative => + (1 => False, -- Actions (List1-Sem) + 2 => False, -- unused + 3 => True, -- Statements (List3) + 4 => True, -- Expression (Node4) + 5 => False), -- unused + N_Case_Statement => (1 => False, -- unused 2 => False, -- unused @@ -10971,6 +11064,13 @@ package Sinfo is 4 => False, -- Entity (Node4-Sem) 5 => False), -- Etype (Node5-Sem) + N_Expression_With_Actions => + (1 => True, -- Actions (List1) + 2 => False, -- unused + 3 => True, -- Expression (Node3) + 4 => False, -- unused + 5 => False), -- unused + N_Free_Statement => (1 => False, -- Storage_Pool (Node1-Sem) 2 => False, -- Procedure_To_Call (Node2-Sem) @@ -11101,41 +11201,27 @@ package Sinfo is -- Entries for SCIL nodes - N_SCIL_Dispatch_Table_Object_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) - 2 => False, -- unused - 3 => False, -- unused - 4 => False, -- SCIL_Entity (Node4-Sem) - 5 => False), -- unused - N_SCIL_Dispatch_Table_Tag_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) + (1 => False, -- unused 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- unused N_SCIL_Dispatching_Call => - (1 => False, -- SCIL_Related_Node (Node1-Sem) + (1 => False, -- unused 2 => False, -- SCIL_Target_Prim (Node2-Sem) 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Controlling_Tag (Node5-Sem) N_SCIL_Membership_Test => - (1 => False, -- SCIL_Related_Node (Node1-Sem) + (1 => False, -- unused 2 => False, -- unused 3 => False, -- unused 4 => False, -- SCIL_Entity (Node4-Sem) 5 => False), -- SCIL_Tag_Value (Node5-Sem) - N_SCIL_Tag_Init => - (1 => False, -- SCIL_Related_Node (Node1-Sem) - 2 => False, -- unused - 3 => False, -- unused - 4 => False, -- SCIL_Entity (Node4-Sem) - 5 => False), -- unused - -- Entries for Empty, Error and Unused. Even thought these have a Chars -- field for debugging purposes, they are not really syntactic fields, so -- we mark all fields as unused. @@ -11331,7 +11417,9 @@ package Sinfo is pragma Inline (Interface_List); pragma Inline (Interface_Present); pragma Inline (Includes_Infinities); + pragma Inline (Import_Interface_Present); pragma Inline (In_Present); + pragma Inline (Inherited_Discriminant); pragma Inline (Instance_Spec); pragma Inline (Intval); pragma Inline (Is_Accessibility_Actual); @@ -11438,7 +11526,6 @@ package Sinfo is pragma Inline (Rounded_Result); pragma Inline (SCIL_Controlling_Tag); pragma Inline (SCIL_Entity); - pragma Inline (SCIL_Related_Node); pragma Inline (SCIL_Tag_Value); pragma Inline (SCIL_Target_Prim); pragma Inline (Scope); @@ -11635,7 +11722,9 @@ package Sinfo is pragma Inline (Set_Includes_Infinities); pragma Inline (Set_Interface_List); pragma Inline (Set_Interface_Present); + pragma Inline (Set_Import_Interface_Present); pragma Inline (Set_In_Present); + pragma Inline (Set_Inherited_Discriminant); pragma Inline (Set_Instance_Spec); pragma Inline (Set_Intval); pragma Inline (Set_Is_Accessibility_Actual); @@ -11742,7 +11831,6 @@ package Sinfo is pragma Inline (Set_Rounded_Result); pragma Inline (Set_SCIL_Controlling_Tag); pragma Inline (Set_SCIL_Entity); - pragma Inline (Set_SCIL_Related_Node); pragma Inline (Set_SCIL_Tag_Value); pragma Inline (Set_SCIL_Target_Prim); pragma Inline (Set_Scope); diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb index 4997346bd8e..aebdcacdd12 100644 --- a/gcc/ada/sinput-c.adb +++ b/gcc/ada/sinput-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -28,7 +28,10 @@ with System; use System; with Ada.Unchecked_Conversion; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); package body Sinput.C is diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 89bbe4c7e40..71700388890 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -6,7 +6,7 @@ -- -- -- T e m p l a t e -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -34,7 +34,7 @@ with Namet; use Namet; package Snames is -- This package contains definitions of standard names (i.e. entries in the --- Names table) that are used throughout the GNAT compiler). It also contains +-- Names table) that are used throughout the GNAT compiler. It also contains -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. @@ -334,6 +334,8 @@ package Snames is Name_Ada_95 : constant Name_Id := N + $; -- GNAT Name_Ada_05 : constant Name_Id := N + $; -- GNAT Name_Ada_2005 : constant Name_Id := N + $; -- GNAT + Name_Ada_12 : constant Name_Id := N + $; -- GNAT + Name_Ada_2012 : constant Name_Id := N + $; -- GNAT Name_Assertion_Policy : constant Name_Id := N + $; -- Ada 05 Name_Assume_No_Invalid_Values : constant Name_Id := N + $; -- GNAT Name_C_Pass_By_Copy : constant Name_Id := N + $; -- GNAT @@ -1416,6 +1418,8 @@ package Snames is Pragma_Ada_95, Pragma_Ada_05, Pragma_Ada_2005, + Pragma_Ada_12, + Pragma_Ada_2012, Pragma_Assertion_Policy, Pragma_Assume_No_Invalid_Values, Pragma_C_Pass_By_Copy, @@ -1690,9 +1694,10 @@ package Snames is -- call this function with a name that is not the name of a attribute. function Get_Convention_Id (N : Name_Id) return Convention_Id; - -- Returns Id of language convention corresponding to given name. It is an - -- to call this function with a name that is not the name of a convention, - -- or one previously given in a call to Record_Convention_Identifier. + -- Returns Id of language convention corresponding to given name. It is + -- an error to call this function with a name that is not the name of a + -- convention, or one that has been previously recorded using a call to + -- Record_Convention_Identifier. function Get_Convention_Name (C : Convention_Id) return Name_Id; -- Returns the name of language convention corresponding to given diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index cc9d5a081f1..44c12f0ab2d 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -403,7 +403,8 @@ package body Sprint is procedure pg (Arg : Union_Id) is begin Dump_Generated_Only := True; - Dump_Original_Only := False; + Dump_Original_Only := False; + Dump_Freeze_Null := True; Current_Source_File := No_Source_File; if Arg in List_Range then @@ -1083,6 +1084,32 @@ package body Sprint is Write_Char (';'); + when N_Case_Expression => + declare + Alt : Node_Id; + + begin + Write_Str_With_Col_Check_Sloc ("(case "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" is"); + + Alt := First (Alternatives (Node)); + loop + Sprint_Node (Alt); + Next (Alt); + exit when No (Alt); + Write_Char (','); + end loop; + + Write_Char (')'); + end; + + when N_Case_Expression_Alternative => + Write_Str_With_Col_Check (" when "); + Sprint_Bar_List (Discrete_Choices (Node)); + Write_Str (" => "); + Sprint_Node (Expression (Node)); + when N_Case_Statement => Write_Indent_Str_Sloc ("case "); Sprint_Node (Expression (Node)); @@ -1224,14 +1251,20 @@ package body Sprint is declare Condition : constant Node_Id := First (Expressions (Node)); Then_Expr : constant Node_Id := Next (Condition); - Else_Expr : constant Node_Id := Next (Then_Expr); + begin Write_Str_With_Col_Check_Sloc ("(if "); Sprint_Node (Condition); Write_Str_With_Col_Check (" then "); - Sprint_Node (Then_Expr); - Write_Str_With_Col_Check (" else "); - Sprint_Node (Else_Expr); + + -- Defense against junk here! + + if Present (Then_Expr) then + Sprint_Node (Then_Expr); + Write_Str_With_Col_Check (" else "); + Sprint_Node (Next (Then_Expr)); + end if; + Write_Char (')'); end; @@ -1508,6 +1541,19 @@ package body Sprint is Write_Char_Sloc ('.'); Write_Str_Sloc ("all"); + when N_Expression_With_Actions => + Indent_Begin; + Write_Indent_Str_Sloc ("do "); + Indent_Begin; + Sprint_Node_List (Actions (Node)); + Indent_End; + Write_Indent; + Write_Str_With_Col_Check_Sloc ("in "); + Sprint_Node (Expression (Node)); + Write_Str_With_Col_Check (" end"); + Indent_End; + Write_Indent; + when N_Extended_Return_Statement => Write_Indent_Str_Sloc ("return "); Sprint_Node_List (Return_Object_Declarations (Node)); @@ -2643,9 +2689,6 @@ package body Sprint is -- Doc of this extended syntax belongs in sinfo.ads and/or -- sprint.ads ??? - when N_SCIL_Dispatch_Table_Object_Init => - Write_Indent_Str ("[N_SCIL_Dispatch_Table_Object_Init]"); - when N_SCIL_Dispatch_Table_Tag_Init => Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); @@ -2655,9 +2698,6 @@ package body Sprint is when N_SCIL_Membership_Test => Write_Indent_Str ("[N_SCIL_Membership_Test]"); - when N_SCIL_Tag_Init => - Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); - when N_Simple_Return_Statement => if Present (Expression (Node)) then Write_Indent_Str_Sloc ("return "); diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index 59c371acbc3..64fe81ae4c5 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -32,6 +32,7 @@ -- tree may either blow up on a debugging check, or list incorrect source. with Types; use Types; + package Sprint is ----------------------- @@ -53,8 +54,8 @@ package Sprint is -- Convert wi Rounded_Result target@(source) -- Divide wi Treat_Fixed_As_Integer x #/ y -- Divide wi Rounded_Result x @/ y + -- Expression with actions do action; .. action; in expr end -- Expression with range check {expression} - -- Operator with range check {operator} (e.g. {+}) -- Free statement free expr [storage_pool = xxx] -- Freeze entity with freeze actions freeze entityname [ actions ] -- Implicit call to run time routine $routine-name @@ -69,6 +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. {+}) -- 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/style.adb b/gcc/ada/style.adb index e700abdf8f8..0f0ab300cba 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -78,11 +78,11 @@ package body Style is begin if Style_Check_Array_Attribute_Index then if D = 1 and then Present (E1) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) index number not allowed for one dimensional array", E1); elsif D > 1 and then No (E1) then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) index number required for multi-dimensional array", N); end if; @@ -161,7 +161,7 @@ package body Style is then Error_Msg_Node_1 := Def; Error_Msg_Sloc := Sloc (Def); - Error_Msg + Error_Msg -- CODEFIX ("(style) bad casing of & declared#", Sref); return; @@ -222,7 +222,7 @@ package body Style is String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)); Set_Casing (Cas); Error_Msg_Name_1 := Name_Enter; - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) bad casing of %% declared in Standard", Ref); end if; end if; @@ -243,10 +243,10 @@ package body Style is if Style_Check_Missing_Overriding and then Comes_From_Source (N) then if Nkind (N) = N_Subprogram_Body then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) missing OVERRIDING indicator in body of%", N); else - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) missing OVERRIDING indicator in declaration of%", N); end if; end if; @@ -259,7 +259,7 @@ package body Style is procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is begin if Style_Check_Order_Subprograms then - Error_Msg_N + Error_Msg_N -- CODEFIX ("(style) subprogram body& not in alphabetical order", Name); end if; end Subprogram_Not_In_Alpha_Order; diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index bf72722cc88..1c22dbcf707 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -237,9 +237,11 @@ package body Styleg is -- Otherwise we have an error elsif Nkind (Orig) = N_Op_And then - Error_Msg ("(style) `AND THEN` required", Sloc (Orig)); + Error_Msg -- CODEFIX + ("(style) `AND THEN` required", Sloc (Orig)); else - Error_Msg ("(style) `OR ELSE` required", Sloc (Orig)); + Error_Msg -- CODEFIX + ("(style) `OR ELSE` required", Sloc (Orig)); end if; end; end if; @@ -434,7 +436,8 @@ package body Styleg is if Scan_Ptr > Source_First (Current_Source_File) and then Source (Scan_Ptr - 1) > ' ' then - Error_Msg_S ("(style) space required"); + Error_Msg_S -- CODEFIX + ("(style) space required"); end if; end if; @@ -447,7 +450,8 @@ package body Styleg is if Source (Scan_Ptr + 2) > ' ' and then not Is_Special_Character (Source (Scan_Ptr + 2)) then - Error_Msg ("(style) space required", Scan_Ptr + 2); + Error_Msg -- CODEFIX + ("(style) space required", Scan_Ptr + 2); end if; end if; @@ -505,7 +509,8 @@ package body Styleg is if Is_Box_Comment then Error_Space_Required (Scan_Ptr + 2); else - Error_Msg ("(style) two spaces required", Scan_Ptr + 2); + Error_Msg -- CODEFIX + ("(style) two spaces required", Scan_Ptr + 2); end if; return; @@ -558,12 +563,12 @@ package body Styleg is -- We expect one blank line, from the EOF, but no more than one if Blank_Lines = 2 then - Error_Msg + Error_Msg -- CODEFIX ("(style) blank line not allowed at end of file", Blank_Line_Location); elsif Blank_Lines >= 3 then - Error_Msg + Error_Msg -- CODEFIX ("(style) blank lines not allowed at end of file", Blank_Line_Location); end if; @@ -590,7 +595,8 @@ package body Styleg is procedure Check_HT is begin if Style_Check_Horizontal_Tabs then - Error_Msg_S ("(style) horizontal tab not allowed"); + Error_Msg_S -- CODEFIX + ("(style) horizontal tab not allowed"); end if; end Check_HT; @@ -608,7 +614,8 @@ package body Styleg is if Token_Ptr = First_Non_Blank_Location and then Start_Column rem Style_Check_Indentation /= 0 then - Error_Msg_SC ("(style) bad indentation"); + Error_Msg_SC -- CODEFIX + ("(style) bad indentation"); end if; end if; end Check_Indentation; @@ -682,9 +689,11 @@ package body Styleg is if Style_Check_Form_Feeds then if Source (Scan_Ptr) = ASCII.FF then - Error_Msg_S ("(style) form feed not allowed"); + Error_Msg_S -- CODEFIX + ("(style) form feed not allowed"); elsif Source (Scan_Ptr) = ASCII.VT then - Error_Msg_S ("(style) vertical tab not allowed"); + Error_Msg_S -- CODEFIX + ("(style) vertical tab not allowed"); end if; end if; @@ -717,7 +726,7 @@ package body Styleg is -- Issue message for blanks at end of line if option enabled if Style_Check_Blanks_At_End and then L < Len then - Error_Msg + Error_Msg -- CODEFIX ("(style) trailing spaces not permitted", S); end if; @@ -913,7 +922,7 @@ package body Styleg is else if Token = Tok_Then then - Error_Msg + Error_Msg -- CODEFIX ("(style) no statements may follow THEN on same line", S); else Error_Msg @@ -977,7 +986,8 @@ package body Styleg is procedure Check_Xtra_Parens (Loc : Source_Ptr) is begin if Style_Check_Xtra_Parens then - Error_Msg ("redundant parentheses?", Loc); + Error_Msg -- CODEFIX + ("redundant parentheses?", Loc); end if; end Check_Xtra_Parens; @@ -996,7 +1006,8 @@ package body Styleg is procedure Error_Space_Not_Allowed (S : Source_Ptr) is begin - Error_Msg ("(style) space not allowed", S); + Error_Msg -- CODEFIX + ("(style) space not allowed", S); end Error_Space_Not_Allowed; -------------------------- @@ -1005,7 +1016,8 @@ package body Styleg is procedure Error_Space_Required (S : Source_Ptr) is begin - Error_Msg ("(style) space required", S); + Error_Msg -- CODEFIX + ("(style) space required", S); end Error_Space_Required; -------------------- @@ -1037,7 +1049,8 @@ package body Styleg is begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; - Error_Msg_SP ("(style) `END &` required"); + Error_Msg_SP -- CODEFIX + ("(style) `END &` required"); end if; end No_End_Name; @@ -1052,7 +1065,8 @@ package body Styleg is begin if Style_Check_End_Labels then Error_Msg_Node_1 := Name; - Error_Msg_SP ("(style) `EXIT &` required"); + Error_Msg_SP -- CODEFIX + ("(style) `EXIT &` required"); end if; end No_Exit_Name; @@ -1067,7 +1081,7 @@ package body Styleg is procedure Non_Lower_Case_Keyword is begin if Style_Check_Keyword_Casing then - Error_Msg_SC -- CODEIX + Error_Msg_SC -- CODEFIX ("(style) reserved words must be all lower case"); end if; end Non_Lower_Case_Keyword; diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index e3e597bcadf..b41296b2cc9 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,9 +23,10 @@ -- -- ------------------------------------------------------------------------------ -with Debug; use Debug; -with Osint; use Osint; -with Opt; use Opt; +with Debug; use Debug; +with Osint; use Osint; +with Opt; use Opt; +with Output; use Output; with System.WCh_Con; use System.WCh_Con; @@ -40,9 +41,35 @@ package body Switch.B is Ptr : Integer := Switch_Chars'First; C : Character := ' '; + function Get_Optional_Filename return String_Ptr; + -- If current character is '=', return a newly allocated string that + -- contains the remainder of the current switch (after the '='), else + -- return null. + function Get_Stack_Size (S : Character) return Int; - -- Used for -d and -D to scan stack size including handling k/m. - -- S is set to 'd' or 'D' to indicate the switch being scanned. + -- Used for -d and -D to scan stack size including handling k/m. S is + -- set to 'd' or 'D' to indicate the switch being scanned. + + --------------------------- + -- Get_Optional_Filename -- + --------------------------- + + function Get_Optional_Filename return String_Ptr is + Result : String_Ptr; + + begin + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + if Ptr = Max then + Bad_Switch (Switch_Chars); + else + Result := new String'(Switch_Chars (Ptr + 1 .. Max)); + Ptr := Max + 1; + return Result; + end if; + end if; + + return null; + end Get_Optional_Filename; -------------------- -- Get_Stack_Size -- @@ -61,11 +88,11 @@ package body Switch.B is pragma Unsuppress (Overflow_Check); begin - -- Check for additional character 'k' (for kilobytes) or 'm' - -- (for Megabytes), but only if we have not reached the end - -- of the switch string. Note that if this appears before the - -- end of the string we will get an error when we test to make - -- sure that the string is exhausted (at the end of the case). + -- Check for additional character 'k' (for kilobytes) or 'm' (for + -- Megabytes), but only if we have not reached the end of the + -- switch string. Note that if this appears before the end of the + -- string we will get an error when we test to make sure that the + -- string is exhausted (at the end of the case). if Ptr <= Max then if Switch_Chars (Ptr) = 'k' then @@ -97,8 +124,8 @@ package body Switch.B is Ptr := Ptr + 1; end if; - -- A little check, "gnat" at the start of a switch is not allowed - -- except for the compiler + -- A little check, "gnat" at the start of a switch is not allowed except + -- for the compiler if Switch_Chars'Last >= Ptr + 3 and then Switch_Chars (Ptr .. Ptr + 3) = "gnat" @@ -124,7 +151,8 @@ package body Switch.B is when 'A' => Ptr := Ptr + 1; - Ada_Bind_File := True; + Output_ALI_List := True; + ALI_List_Filename := Get_Optional_Filename; -- Processing for b switch @@ -136,16 +164,16 @@ package body Switch.B is when 'c' => Ptr := Ptr + 1; - Check_Only := True; -- Processing for C switch when 'C' => Ptr := Ptr + 1; - Ada_Bind_File := False; + Write_Line ("warning: gnatbind switch -C is obsolescent"); + -- Processing for d switch when 'd' => @@ -243,6 +271,20 @@ package body Switch.B is Ptr := Ptr + 1; Usage_Requested := True; + -- Processing for H switch + + when 'H' => + if Ptr = Max then + Bad_Switch (Switch_Chars); + end if; + + Ptr := Ptr + 1; + Scan_Nat (Switch_Chars, Max, Ptr, Heap_Size, C); + + if Heap_Size /= 32 and then Heap_Size /= 64 then + Bad_Switch (Switch_Chars); + end if; + -- Processing for i switch when 'i' => @@ -253,7 +295,7 @@ package body Switch.B is Ptr := Ptr + 1; C := Switch_Chars (Ptr); - if C in '1' .. '5' + if C in '1' .. '5' or else C = '8' or else C = 'p' or else C = 'f' @@ -305,7 +347,6 @@ package body Switch.B is if Output_File_Name_Present then Osint.Fail ("duplicate -o switch"); - else Output_File_Name_Present := True; end if; @@ -315,6 +356,7 @@ package body Switch.B is when 'O' => Ptr := Ptr + 1; Output_Object_List := True; + Object_List_Filename := Get_Optional_Filename; -- Processing for p switch @@ -338,7 +380,6 @@ package body Switch.B is when 'R' => Ptr := Ptr + 1; - Check_Only := True; List_Closure := True; -- Processing for s switch @@ -400,7 +441,6 @@ package body Switch.B is Ptr := Ptr + 1; case Switch_Chars (Ptr) is - when 'e' => Warning_Mode := Treat_As_Error; @@ -433,8 +473,7 @@ package body Switch.B is Wide_Character_Encoding_Method_Specified := True; Upper_Half_Encoding := - Wide_Character_Encoding_Method in - WC_Upper_Half_Encoding_Method; + Wide_Character_Encoding_Method in WC_Upper_Half_Encoding_Method; Ptr := Ptr + 1; @@ -486,7 +525,7 @@ package body Switch.B is Osint.Fail ("missing path for --RTS"); else - -- valid --RTS switch + -- Valid --RTS switch Opt.No_Stdinc := True; Opt.RTS_Switch := True; @@ -508,8 +547,8 @@ package body Switch.B is Lib_Path_Name /= null then -- Set the RTS_*_Path_Name variables, so that the - -- correct directories will be set when - -- Osint.Add_Default_Search_Dirs will be called later. + -- correct directories will be set when a subsequent + -- call Osint.Add_Default_Search_Dirs is made. RTS_Src_Path_Name := Src_Path_Name; RTS_Lib_Path_Name := Lib_Path_Name; diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 7b194107ff6..ab213af14bb 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -32,8 +32,7 @@ with Validsw; use Validsw; with Sem_Warn; use Sem_Warn; with Stylesw; use Stylesw; -with System.OS_Lib; use System.OS_Lib; - +with System.Strings; with System.WCh_Con; use System.WCh_Con; package body Switch.C is @@ -41,11 +40,25 @@ package body Switch.C is RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= flag + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean; + -- This function is called from Scan_Front_End_Switches. It determines if + -- the switch currently being scanned is followed by a switch of the form + -- "-gnat-" & C, where C is the argument. If so, then True is returned, + -- and Scan_Front_End_Switches will cancel the effect of the switch. If + -- no such switch is found, False is returned. + ----------------------------- -- Scan_Front_End_Switches -- ----------------------------- - procedure Scan_Front_End_Switches (Switch_Chars : String) is + procedure Scan_Front_End_Switches + (Switch_Chars : String; + Args : Argument_List; + Arg_Rank : Positive) + is First_Switch : Boolean := True; -- False for all but first switch @@ -519,11 +532,11 @@ package body Switch.C is System_Extend_Unit := Empty; Warning_Mode := Treat_As_Error; - -- Set Ada 2005 mode explicitly. We don't want to rely on the + -- Set Ada 2012 mode explicitly. We don't want to rely on the -- implicit setting here, since for example, we want -- Preelaborate_05 treated as Preelaborate - Ada_Version := Ada_05; + Ada_Version := Ada_12; Ada_Version_Explicit := Ada_Version; -- Set default warnings and style checks for -gnatg @@ -662,20 +675,27 @@ package body Switch.C is when 'p' => Ptr := Ptr + 1; - -- Set all specific options as well as All_Checks in the - -- Suppress_Options array, excluding Elaboration_Check, since - -- this is treated specially because we do not want -gnatp to - -- disable static elaboration processing. + -- Skip processing if cancelled by subsequent -gnat-p - for J in Suppress_Options'Range loop - if J /= Elaboration_Check then - Suppress_Options (J) := True; - end if; - end loop; + if Switch_Subsequently_Cancelled ("p", Args, Arg_Rank) then + Store_Switch := False; - Validity_Checks_On := False; - Opt.Suppress_Checks := True; - Opt.Enable_Overflow_Checks := False; + else + -- Set all specific options as well as All_Checks in the + -- Suppress_Options array, excluding Elaboration_Check, + -- since this is treated specially because we do not want + -- -gnatp to disable static elaboration processing. + + for J in Suppress_Options'Range loop + if J /= Elaboration_Check then + Suppress_Options (J) := True; + end if; + end loop; + + Validity_Checks_On := False; + Opt.Suppress_Checks := True; + Opt.Enable_Overflow_Checks := False; + end if; -- Processing for P switch @@ -883,6 +903,8 @@ package body Switch.C is when 'X' => Ptr := Ptr + 1; Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + Ada_Version_Explicit := Ada_Version_Type'Last; -- Processing for y switch @@ -933,6 +955,7 @@ package body Switch.C is -- Processing for z switch when 'z' => + -- -gnatz must be the first and only switch in Switch_Chars, -- and is a two-letter switch. @@ -1027,11 +1050,68 @@ package body Switch.C is Ada_Version_Explicit := Ada_Version; end if; - -- Ignore extra switch character + -- Processing for 12 switch + + when '1' => + if Ptr = Max then + Bad_Switch ("-gnat1"); + end if; - when '/' | '-' => Ptr := Ptr + 1; + if Switch_Chars (Ptr) /= '2' then + Bad_Switch ("-gnat1" & Switch_Chars (Ptr .. Max)); + else + Ptr := Ptr + 1; + Ada_Version := Ada_12; + Ada_Version_Explicit := Ada_Version; + end if; + + -- Processing for 2005 and 2012 switches + + when '2' => + if Ptr > Max - 3 then + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Max)); + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2005" then + Ada_Version := Ada_05; + + elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then + Ada_Version := Ada_12; + + else + Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3)); + end if; + + Ada_Version_Explicit := Ada_Version; + Ptr := Ptr + 4; + + -- Switch cancellation, currently only -gnat-p is allowed. + -- All we do here is the error checking, since the actual + -- processing for switch cancellation is done by calls to + -- Switch_Subsequently_Cancelled at the appropriate point. + + when '-' => + + -- Simple ignore -gnat-p + + if Switch_Chars = "-gnat-p" then + return; + + -- Any other occurrence of minus is ignored. This is for + -- maximum compatibility with previous version which ignored + -- all occurrences of minus. + + else + Store_Switch := False; + Ptr := Ptr + 1; + end if; + + -- We ignore '/' in switches, this is historical, still needed??? + + when '/' => + Store_Switch := False; + -- Anything else is an error (illegal switch character) when others => @@ -1048,4 +1128,29 @@ package body Switch.C is end if; end Scan_Front_End_Switches; + ----------------------------------- + -- Switch_Subsequently_Cancelled -- + ----------------------------------- + + function Switch_Subsequently_Cancelled + (C : String; + Args : Argument_List; + Arg_Rank : Positive) return Boolean + is + use type System.Strings.String_Access; + + begin + -- Loop through arguments following the current one + + for Arg in Arg_Rank + 1 .. Args'Last loop + if Args (Arg).all = "-gnat-" & C then + return True; + end if; + end loop; + + -- No match found, not cancelled + + return False; + end Switch_Subsequently_Cancelled; + end Switch.C; diff --git a/gcc/ada/switch-c.ads b/gcc/ada/switch-c.ads index 09ac49ecb57..1595858a28d 100644 --- a/gcc/ada/switch-c.ads +++ b/gcc/ada/switch-c.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,15 +29,24 @@ -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. +with System.OS_Lib; use System.OS_Lib; + package Switch.C is - procedure Scan_Front_End_Switches (Switch_Chars : String); + procedure Scan_Front_End_Switches + (Switch_Chars : String; + Args : Argument_List; + Arg_Rank : Positive); -- Procedures to scan out front end switches stored in the given string. -- The first character is known to be a valid switch character, and there -- are no blanks or other switch terminator characters in the string, so -- the entire string should consist of valid switch characters, except that -- an optional terminating NUL character is allowed. A bad switch causes -- a fatal error exit and control does not return. The call also sets - -- Usage_Requested to True if a ? switch is encountered. + -- Usage_Requested to True if a switch -gnath is encountered. + -- + -- Args is the full list of command line arguments. Arg_Rank is the + -- position of the switch in Args. It is used for certain switches -gnatx + -- to check if a subsequent switch -gnat-x cancels the switch -gnatx. end Switch.C; diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb index a7a8d192626..11491d3de42 100644 --- a/gcc/ada/switch-m.adb +++ b/gcc/ada/switch-m.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -71,7 +71,7 @@ package body Switch.M is procedure Add_Switch_Component (S : String); -- Add a new String_Access component in Switches. If a string equal -- to S is already stored in the table Normalized_Switches, use it. - -- Other wise add a new component to the table. + -- Otherwise add a new component to the table. -------------------------- -- Add_Switch_Component -- @@ -215,10 +215,10 @@ package body Switch.M is -- One-letter switches - when 'a' | 'A' | 'b' | 'c' | 'D' | 'E' | 'f' | - 'F' | 'g' | 'h' | 'H' | 'k' | 'l' | 'L' | 'n' | 'N' | - 'o' | 'O' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 't' | - 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => + when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | + 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'n' | 'N' | + 'o' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | + 't' | 'u' | 'U' | 'v' | 'x' | 'X' | 'Z' => Storing (First_Stored) := C; Add_Switch_Component (Storing (Storing'First .. First_Stored)); @@ -226,10 +226,14 @@ package body Switch.M is -- One-letter switches followed by a positive number - when 'm' | 'T' => + when 'D' | 'G' | 'j' | 'k' | 'm' | 'T' => Storing (First_Stored) := C; Last_Stored := First_Stored; + if Ptr <= Max and then Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; + loop Ptr := Ptr + 1; exit when Ptr > Max @@ -268,63 +272,93 @@ package body Switch.M is when 'e' => - -- Store -gnateD, -gnatep= and -gnateG in the ALI file. - -- The other -gnate switches do not need to be stored. + -- Some of the gnate... switches are not stored Storing (First_Stored) := 'e'; Ptr := Ptr + 1; - if Ptr > Max - or else (Switch_Chars (Ptr) /= 'D' - and then Switch_Chars (Ptr) /= 'G' - and then Switch_Chars (Ptr) /= 'p') - then + if Ptr > Max then Last := 0; return; - end if; - -- Processing for -gnateD + else + case Switch_Chars (Ptr) is - if Switch_Chars (Ptr) = 'D' then - Storing (First_Stored + 1 .. - First_Stored + Max - Ptr + 1) := - Switch_Chars (Ptr .. Max); - Add_Switch_Component - (Storing (Storing'First .. - First_Stored + Max - Ptr + 1)); + when 'D' => + Storing (First_Stored + 1 .. + First_Stored + Max - Ptr + 1) := + Switch_Chars (Ptr .. Max); + Add_Switch_Component + (Storing (Storing'First .. + First_Stored + Max - Ptr + 1)); + Ptr := Max + 1; - -- Processing for -gnatep= + when 'G' => + Ptr := Ptr + 1; + Add_Switch_Component ("-gnateG"); - elsif Switch_Chars (Ptr) = 'p' then - Ptr := Ptr + 1; + when 'I' => + Ptr := Ptr + 1; - if Ptr = Max then - Last := 0; - return; - end if; + declare + First : constant Positive := Ptr - 1; + begin + if Ptr <= Max and then + Switch_Chars (Ptr) = '=' + then + Ptr := Ptr + 1; + end if; + + while Ptr <= Max and then + Switch_Chars (Ptr) in '0' .. '9' + loop + Ptr := Ptr + 1; + end loop; + + Storing (First_Stored + 1 .. + First_Stored + Ptr - First) := + Switch_Chars (First .. Ptr - 1); + Add_Switch_Component + (Storing (Storing'First .. + First_Stored + Ptr - First)); + end; + + when 'p' => + Ptr := Ptr + 1; - if Switch_Chars (Ptr) = '=' then - Ptr := Ptr + 1; - end if; + if Ptr = Max then + Last := 0; + return; + end if; - -- To normalize, always put a '=' after -gnatep. - -- Because that could lengthen the switch string, - -- declare a local variable. - - declare - To_Store : String (1 .. Max - Ptr + 9); - begin - To_Store (1 .. 8) := "-gnatep="; - To_Store (9 .. Max - Ptr + 9) := - Switch_Chars (Ptr .. Max); - Add_Switch_Component (To_Store); - end; - - elsif Switch_Chars (Ptr) = 'G' then - Add_Switch_Component ("-gnateG"); - end if; + if Switch_Chars (Ptr) = '=' then + Ptr := Ptr + 1; + end if; - return; + -- To normalize, always put a '=' after + -- -gnatep. Because that could lengthen the + -- switch string, declare a local variable. + + declare + To_Store : String (1 .. Max - Ptr + 9); + begin + To_Store (1 .. 8) := "-gnatep="; + To_Store (9 .. Max - Ptr + 9) := + Switch_Chars (Ptr .. Max); + Add_Switch_Component (To_Store); + end; + + return; + + when 'S' => + Ptr := Ptr + 1; + Add_Switch_Component ("-gnateS"); + + when others => + Last := 0; + return; + end case; + end if; when 'i' => Storing (First_Stored) := 'i'; @@ -355,6 +389,20 @@ package body Switch.M is return; end if; + -- -gnatl may be -gnatl=<file name> + + when 'l' => + Ptr := Ptr + 1; + + if Ptr > Max or else Switch_Chars (Ptr) /= '=' then + Add_Switch_Component ("-gnatl"); + + else + Add_Switch_Component + ("-gnatl" & Switch_Chars (Ptr .. Max)); + return; + end if; + -- -gnatR may be followed by '0', '1', '2' or '3', -- then by 's' @@ -390,6 +438,26 @@ package body Switch.M is Add_Switch_Component (Storing (Storing'First .. Last_Stored)); + -- -gnatWx, x = 'h'. 'u', 's', 'e', '8' or 'b' + + when 'W' => + Storing (First_Stored) := 'W'; + Ptr := Ptr + 1; + + if Ptr <= Max then + case Switch_Chars (Ptr) is + when 'h' | 'u' | 's' | 'e' | '8' | 'b' => + Storing (First_Stored + 1) := Switch_Chars (Ptr); + Add_Switch_Component + (Storing (Storing'First .. First_Stored + 1)); + Ptr := Ptr + 1; + + when others => + Last := 0; + return; + end case; + end if; + -- Multiple switches when 'V' | 'w' | 'y' => @@ -584,6 +652,9 @@ package body Switch.M is (Switch_Chars'First + Subdirs_Option'Length .. Switch_Chars'Last)); + elsif Switch_Chars = Makeutl.Unchecked_Shared_Lib_Imports then + Opt.Unchecked_Shared_Lib_Imports := True; + elsif Switch_Chars (Ptr) = '-' then Bad_Switch (Switch_Chars); @@ -839,6 +910,7 @@ package body Switch.M is when 'x' => External_Unit_Compilation_Allowed := True; + Use_Include_Path_File := True; -- Processing for z switch diff --git a/gcc/ada/switch-m.ads b/gcc/ada/switch-m.ads index 6a800234083..de7ccaf5d5d 100644 --- a/gcc/ada/switch-m.ads +++ b/gcc/ada/switch-m.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -29,7 +29,11 @@ -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); + with Prj.Tree; package Switch.M is diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 6dcc66fa790..c978c036a35 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2010, 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- * @@ -158,7 +158,7 @@ extern struct tm *localtime_r(const time_t *, struct tm *); */ -#if defined(WINNT) || defined (MSDOS) || defined (__EMX__) +#if defined(WINNT) static const char *mode_read_text = "rt"; static const char *mode_write_text = "wt"; static const char *mode_append_text = "at"; @@ -345,7 +345,7 @@ __gnat_ttyname (int filedes) } #endif -#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ +#if defined (linux) || defined (sun) || defined (sgi) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \ || defined (__MACHTEN__) || defined (__hpux__) || defined (_AIX) \ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \ @@ -403,7 +403,7 @@ getc_immediate_common (FILE *stream, int *avail, int waiting) { -#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ +#if defined (linux) || defined (sun) || defined (sgi) \ || (defined (__osf__) && ! defined (__alpha_vxworks)) \ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ @@ -424,7 +424,7 @@ getc_immediate_common (FILE *stream, /* Set RAW mode, with no echo */ termios_rec.c_lflag = termios_rec.c_lflag & ~ICANON & ~ECHO; -#if defined(linux) || defined (sun) || defined (sgi) || defined (__EMX__) \ +#if defined(linux) || defined (sun) || defined (sgi) \ || defined (__osf__) || defined (__MACHTEN__) || defined (__hpux__) \ || defined (_AIX) || (defined (__svr4__) && defined (i386)) \ || defined (__Lynx__) || defined (__FreeBSD__) || defined (__OpenBSD__) \ @@ -433,18 +433,12 @@ getc_immediate_common (FILE *stream, /* If waiting (i.e. Get_Immediate (Char)), set MIN = 1 and wait for a character forever. This doesn't seem to effect Ctrl-Z or - Ctrl-C processing except on OS/2 where Ctrl-C won't work right - unless we do a read loop. Luckily we can delay a bit between - iterations. If not waiting (i.e. Get_Immediate (Char, Available)), + Ctrl-C processing. + If not waiting (i.e. Get_Immediate (Char, Available)), don't wait for anything but timeout immediately. */ -#ifdef __EMX__ - termios_rec.c_cc[VMIN] = 0; - termios_rec.c_cc[VTIME] = waiting; -#else termios_rec.c_cc[VMIN] = waiting; termios_rec.c_cc[VTIME] = 0; #endif -#endif tcsetattr (fd, TCSANOW, &termios_rec); while (! good_one) @@ -720,7 +714,7 @@ long __gnat_invalid_tzoff = 259273; /* Definition of __gnat_localtime_r used by a-calend.adb */ -#if defined (__EMX__) || defined (__MINGW32__) +#if defined (__MINGW32__) #ifdef CERT @@ -743,7 +737,7 @@ extern void (*Unlock_Task) (void); #endif -/* Reentrant localtime for Windows and OS/2. */ +/* Reentrant localtime for Windows. */ extern void __gnat_localtime_tzoff (const time_t *, long *); diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads index 57fece94076..f5d806ddf77 100644 --- a/gcc/ada/system-vms-ia64.ads +++ b/gcc/ada/system-vms-ia64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -239,7 +239,7 @@ private -- Special VMS Interfaces -- ---------------------------- - procedure Lib_Stop (I : Integer); + procedure Lib_Stop (Cond_Value : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma @@ -251,4 +251,7 @@ private -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + end System; diff --git a/gcc/ada/system-vms-zcx.ads b/gcc/ada/system-vms-zcx.ads deleted file mode 100644 index 5b4c3edb5d6..00000000000 --- a/gcc/ada/system-vms-zcx.ads +++ /dev/null @@ -1,232 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS GCC_ZCX DEC Threads Version) -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 <your application> - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f <your options> <your application> - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - -end System; diff --git a/gcc/ada/system-vms.ads b/gcc/ada/system-vms.ads deleted file mode 100644 index 4b6f1eacdad..00000000000 --- a/gcc/ada/system-vms.ads +++ /dev/null @@ -1,237 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS DEC Threads Version) -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - type Address is mod Memory_Size; - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - Support_Aggregates : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := False; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 <your application> - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f <your options> <your application> - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - ADA_GNAT : constant Boolean := True; - pragma Export_Object (ADA_GNAT, "ADA$GNAT"); - -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. - -- Do not remove! - -end System; diff --git a/gcc/ada/system-vms_64.ads b/gcc/ada/system-vms_64.ads index 17b1ab81504..2934699420a 100644 --- a/gcc/ada/system-vms_64.ads +++ b/gcc/ada/system-vms_64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -239,7 +239,7 @@ private -- Special VMS Interfaces -- ---------------------------- - procedure Lib_Stop (I : Integer); + procedure Lib_Stop (Cond_Value : Integer); pragma Interface (C, Lib_Stop); pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); -- Interface to VMS condition handling. Used by RTSfind and pragma @@ -251,4 +251,7 @@ private -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. -- Do not remove! + pragma Ident ("GNAT"); -- Gnat_Static_Version_String + -- Default ident for all VMS images. + end System; diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 3da3c611198..ed9a7138c43 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -442,9 +442,9 @@ package body Tbuild is function Make_Temporary (Loc : Source_Ptr; Id : Character; - Related_Node : Node_Id := Empty) return Node_Id + Related_Node : Node_Id := Empty) return Entity_Id is - Temp : constant Node_Id := + Temp : constant Entity_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id)); begin @@ -659,7 +659,7 @@ package body Tbuild is -- We don't really need these shift operators, since they never -- appear as operators in the source, but the path of least - -- resistance is to put them in (the aggregate must be complete) + -- resistance is to put them in (the aggregate must be complete). N_Op_Rotate_Left => Name_Rotate_Left, N_Op_Rotate_Right => Name_Rotate_Right, @@ -686,7 +686,6 @@ package body Tbuild is Loc : Source_Ptr) return Node_Id is Occurrence : Node_Id; - begin Occurrence := New_Node (N_Identifier, Loc); Set_Chars (Occurrence, Chars (Def_Id)); diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 0b73a53d220..da41111943b 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -179,11 +179,20 @@ package Tbuild is function Make_Temporary (Loc : Source_Ptr; Id : Character; - Related_Node : Node_Id := Empty) return Node_Id; - -- Create a defining identifier to capture the value of an expression - -- or aggregate, and link it to the expression that it replaces, in - -- order to provide better CodePeer reports. The defining identifier - -- name is obtained by Make_Internal_Name (Id). + Related_Node : Node_Id := Empty) return Entity_Id; + -- This function should be used for all cases where a defining identifier + -- is to be built with a name to be obtained by New_Internal_Name (here Id + -- is the character passed as the argument to New_Internal_Name). Loc is + -- the location for the Sloc value of the resulting Entity. Note that this + -- can be used for all kinds of temporary defining identifiers used in + -- expansion (objects, subtypes, functions etc). + -- + -- Related_Node is used when the defining identifier is for an object that + -- captures the value of an expression (e.g. an aggregate). It should be + -- set whenever possible to point to the expression that is being captured. + -- This is provided to get better error messages, e.g. from CodePeer. + -- + -- Make_Temp_Id would probably be a better name for this function??? function Make_Unsuppress_Block (Loc : Source_Ptr; @@ -268,6 +277,9 @@ package Tbuild is -- if the identical unit is compiled with a semantically consistent set -- of sources, the numbers will be consistent. This means that it is fine -- to use these as public symbols. + -- + -- Note: Nearly all uses of this function are via calls to Make_Temporary, + -- but there are just a few cases where it is called directly. function New_Occurrence_Of (Def_Id : Entity_Id; diff --git a/gcc/ada/tempdir.ads b/gcc/ada/tempdir.ads index a73b5a417ca..7ab1b5aff86 100644 --- a/gcc/ada/tempdir.ads +++ b/gcc/ada/tempdir.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2010, 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- -- @@ -30,7 +30,7 @@ with Namet; use Namet; -with System.OS_Lib; use System.OS_Lib; +with GNAT.OS_Lib; use GNAT.OS_Lib; package Tempdir is diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index c436054176a..0cb17fed26f 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -34,10 +34,13 @@ -- create and close routines are elsewhere (in Osint in the compiler, and in -- the tree read driver for the tree read interface). -with Types; use Types; +with Types; use Types; +with System; use System; -with System; use System; +pragma Warnings (Off); +-- This package is used also by gnatcoll with System.OS_Lib; use System.OS_Lib; +pragma Warnings (On); package Tree_IO is diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index c2f0770f29e..087170f69fe 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -38,6 +38,7 @@ with Snames; use Snames; with Sinput; use Sinput; with Stand; use Stand; with Stringt; use Stringt; +with SCIL_LL; use SCIL_LL; with Treeprs; use Treeprs; with Uintp; use Uintp; with Urealp; use Urealp; @@ -626,6 +627,14 @@ package body Treepr is Print_Eol; end if; + if Field_Present (Field28 (Ent)) then + Print_Str (Prefix); + Write_Field28_Name (Ent); + Write_Str (" = "); + Print_Field (Field28 (Ent)); + Print_Eol; + end if; + Write_Entity_Flags (Ent, Prefix); end Print_Entity_Info; @@ -1188,6 +1197,14 @@ package body Treepr is Print_Entity_Info (N, Prefix_Str_Char); end if; + -- Print the SCIL node (if available) + + if Present (Get_SCIL_Node (N)) then + Print_Str (Prefix_Str_Char); + Print_Str ("SCIL_Node = "); + Print_Node_Ref (Get_SCIL_Node (N)); + Print_Eol; + end if; end Print_Node; --------------------- diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index cc3603aafa0..5d7784dc03b 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -59,9 +59,6 @@ package Types is type Int is range -2 ** 31 .. +2 ** 31 - 1; -- Signed 32-bit integer - type Dint is range -2 ** 63 .. +2 ** 63 - 1; - -- Double length (64-bit) integer - subtype Nat is Int range 0 .. Int'Last; -- Non-negative Int values @@ -348,16 +345,16 @@ package Types is -- lie in. Such tests appear only in the lowest level packages. subtype List_Range is Union_Id - range List_Low_Bound .. List_High_Bound; + range List_Low_Bound .. List_High_Bound; subtype Node_Range is Union_Id - range Node_Low_Bound .. Node_High_Bound; + range Node_Low_Bound .. Node_High_Bound; subtype Elist_Range is Union_Id - range Elist_Low_Bound .. Elist_High_Bound; + range Elist_Low_Bound .. Elist_High_Bound; subtype Elmt_Range is Union_Id - range Elmt_Low_Bound .. Elmt_High_Bound; + range Elmt_Low_Bound .. Elmt_High_Bound; subtype Names_Range is Union_Id range Names_Low_Bound .. Names_High_Bound; @@ -369,23 +366,23 @@ package Types is range Uint_Low_Bound .. Uint_High_Bound; subtype Ureal_Range is Union_Id - range Ureal_Low_Bound .. Ureal_High_Bound; + range Ureal_Low_Bound .. Ureal_High_Bound; - ---------------------------- + ----------------------------- -- Types for Atree Package -- - ---------------------------- + ----------------------------- -- Node_Id values are used to identify nodes in the tree. They are - -- subscripts into the Node table declared in package Tree. Note that - -- the special values Empty and Error are subscripts into this table, + -- subscripts into the Nodes table declared in package Atree. Note that + -- the special values Empty and Error are subscripts into this table. -- See package Atree for further details. type Node_Id is range Node_Low_Bound .. Node_High_Bound; -- Type used to identify nodes in the tree subtype Entity_Id is Node_Id; - -- A synonym for node types, used in the entity package to refer to nodes - -- that are entities (i.e. nodes with an Nkind of N_Defining_xxx) All such + -- A synonym for node types, used in the Einfo package to refer to nodes + -- that are entities (i.e. nodes with an Nkind of N_Defining_xxx). All such -- nodes are extended nodes and these are the only extended nodes, so that -- in practice entity and extended nodes are synonymous. @@ -402,12 +399,12 @@ package Types is Empty_List_Or_Node : constant := 0; -- This constant is used in situations (e.g. initializing empty fields) - -- where the value set will be used to represent either an empty node - -- or a non-existent list, depending on the context. + -- where the value set will be used to represent either an empty node or + -- a non-existent list, depending on the context. Error : constant Node_Id := Node_Low_Bound + 1; - -- Used to indicate that there was an error in the source program. A node - -- is actually allocated at this address, so that Nkind (Error) = N_Error. + -- Used to indicate an error in the source program. A node is actually + -- allocated with this Id value, so that Nkind (Error) = N_Error. Empty_Or_Error : constant Node_Id := Error; -- Since Empty and Error are the first two Node_Id values, the test for @@ -422,11 +419,12 @@ package Types is -- Types for Nlists Package -- ------------------------------ - -- List_Id values are used to identify node lists in the tree. They are - -- subscripts into the Lists table declared in package Tree. Note that the - -- special value Error_List is a subscript in this table, but the value - -- No_List is *not* a valid subscript, and any attempt to apply list - -- operations to No_List will cause a (detected) error. + -- List_Id values are used to identify node lists stored in the tree, so + -- that each node can be on at most one such list (see package Nlists for + -- further details). Note that the special value Error_List is a subscript + -- in this table, but the value No_List is *not* a valid subscript, and any + -- attempt to apply list operations to No_List will cause a (detected) + -- error. type List_Id is range List_Low_Bound .. List_High_Bound; -- Type used to identify a node list @@ -449,24 +447,23 @@ package Types is -- Types for Elists Package -- ------------------------------ - -- Element list Id values are used to identify element lists stored in the - -- tree (see package Atree for further details). They are formed by adding - -- a bias (Element_List_Bias) to subscript values in the same array that is - -- used for node list headers. + -- Element list Id values are used to identify element lists stored outside + -- of the tree, allowing nodes to be members of more than one such list + -- (see package Elists for further details). type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; -- Type used to identify an element list (Elist header table subscript) No_Elist : constant Elist_Id := Elist_Low_Bound; - -- Used to indicate absence of an element list. Note that this is not - -- an actual Elist header, so element list operations on this value - -- are not valid. + -- Used to indicate absence of an element list. Note that this is not an + -- actual Elist header, so element list operations on this value are not + -- valid. First_Elist_Id : constant Elist_Id := No_Elist + 1; -- Subscript of first allocated Elist header - -- Element Id values are used to identify individual elements of an - -- element list (see package Elists for further details). + -- Element Id values are used to identify individual elements of an element + -- list (see package Elists for further details). type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound; -- Type used to identify an element list @@ -482,11 +479,12 @@ package Types is ------------------------------- -- String_Id values are used to identify entries in the strings table. They - -- are subscripts into the strings table defined in package Strings. + -- are subscripts into the Strings table defined in package Stringt. -- Note that with only a few exceptions, which are clearly documented, the -- type String_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. + -- Doesn't this also apply to all other *_Id types??? type String_Id is range Strings_Low_Bound .. Strings_High_Bound; -- Type used to identify entries in the strings table @@ -505,10 +503,10 @@ package Types is -- The type Char is used for character data internally in the compiler, but -- character codes in the source are represented by the Char_Code type. -- Each character literal in the source is interpreted as being one of the - -- 16#8000_0000 possible Wide_Wide_Character codes, and a unique Integer - -- Value is assigned, corresponding to the UTF_32 value, which also - -- corresponds to the POS value in the Wide_Wide_Character type, and also - -- corresponds to the POS value in the Wide_Character and Character types + -- 16#7FFF_FFFF# possible Wide_Wide_Character codes, and a unique Integer + -- value is assigned, corresponding to the UTF-32 value, which also + -- corresponds to the Pos value in the Wide_Wide_Character type, and also + -- corresponds to the Pos value in the Wide_Character and Character types -- for values that are in appropriate range. String literals are similarly -- interpreted as a sequence of such codes. @@ -554,7 +552,7 @@ package Types is type Unit_Number_Type is new Int; -- Unit number. The main source is unit 0, and subsidiary sources have -- non-zero numbers starting with 1. Unit numbers are used to index the - -- file table in Lib. + -- Units table in package Lib. Main_Unit : constant Unit_Number_Type := 0; -- Unit number value for main unit @@ -730,14 +728,14 @@ package Types is -- Parameter Mechanism Control -- --------------------------------- - -- Function and parameter entities have a field that records the - -- passing mechanism. See specification of Sem_Mech for full details. - -- The following subtype is used to represent values of this type: + -- Function and parameter entities have a field that records the passing + -- mechanism. See specification of Sem_Mech for full details. The following + -- subtype is used to represent values of this type: subtype Mechanism_Type is Int range -18 .. Int'Last; - -- Type used to represent a mechanism value. This is a subtype rather - -- than a type to avoid some annoying processing problems with certain - -- routines in Einfo (processing them to create the corresponding C). + -- Type used to represent a mechanism value. This is a subtype rather than + -- a type to avoid some annoying processing problems with certain routines + -- in Einfo (processing them to create the corresponding C). ------------------------------ -- Run-Time Exception Codes -- @@ -762,12 +760,12 @@ package Types is -- 1. Modify the type and subtype declarations below appropriately, -- keeping things in alphabetical order. - -- 2. Modify the corresponding definitions in types.h, including - -- the definition of last_reason_code. + -- 2. Modify the corresponding definitions in types.h, including the + -- definition of last_reason_code. - -- 3. Add a new routine in Ada.Exceptions with the appropriate call - -- and static string constant. Note that there is more than one - -- version of a-except.adb which must be modified. + -- 3. Add a new routine in Ada.Exceptions with the appropriate call and + -- static string constant. Note that there is more than one version + -- of a-except.adb which must be modified. type RT_Exception_Code is (CE_Access_Check_Failed, -- 00 diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 5e168d2798d..efa5356dff3 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -85,6 +85,7 @@ gcc -c ^ GNAT COMPILE -gnatN ^ /INLINE=FULL -gnato ^ /CHECKS=OVERFLOW -gnatp ^ /CHECKS=SUPPRESS_ALL +-gnat-p ^ /CHECKS=UNSUPPRESS_ALL -gnatP ^ /POLLING -gnatR ^ /REPRESENTATION_INFO -gnatR0 ^ /REPRESENTATION_INFO=NONE diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 3b72d154c10..29ffe235aad 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -168,13 +168,15 @@ package body Uintp is (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; - Discard_Quotient : Boolean; - Discard_Remainder : Boolean); - -- Compute Euclidean division of Left by Right, and return Quotient and - -- signed Remainder (Left rem Right). + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False); + -- Compute Euclidean division of Left by Right. If Discard_Quotient is + -- False then the quotient is returned in Quotient (otherwise Quotient is + -- set to No_Uint). If Discard_Remainder is False, then the remainder is + -- returned in Remainder (otherwise Remainder is set to No_Uint). -- - -- If Discard_Quotient is True, Quotient is left unchanged. - -- If Discard_Remainder is True, Remainder is left unchanged. + -- If Discard_Quotient is True, Quotient is set to No_Uint + -- If Discard_Remainder is True, Remainder is set to No_Uint function Vector_To_Uint (In_Vec : UI_Vector; @@ -239,7 +241,7 @@ package body Uintp is function Hash_Num (F : Int) return Hnum is begin - return Standard."mod" (F, Hnum'Range_Length); + return Types."mod" (F, Hnum'Range_Length); end Hash_Num; --------------- @@ -1253,7 +1255,6 @@ package body Uintp is UI_Div_Rem (Left, Right, Quotient, Remainder, - Discard_Quotient => False, Discard_Remainder => True); return Quotient; end UI_Div; @@ -1266,14 +1267,17 @@ package body Uintp is (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; - Discard_Quotient : Boolean; - Discard_Remainder : Boolean) + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False) is pragma Warnings (Off, Quotient); pragma Warnings (Off, Remainder); begin pragma Assert (Right /= Uint_0); + Quotient := No_Uint; + Remainder := No_Uint; + -- Cases where both operands are represented directly if Direct (Left) and then Direct (Right) then @@ -1345,9 +1349,11 @@ package body Uintp is if not Discard_Quotient then Quotient := Uint_0; end if; + if not Discard_Remainder then Remainder := Left; end if; + return; end if; @@ -1377,6 +1383,7 @@ package body Uintp is if not Discard_Remainder then Remainder := UI_From_Int (Remainder_I); end if; + return; end; end if; @@ -1679,43 +1686,9 @@ package body Uintp is function UI_From_CC (Input : Char_Code) return Uint is begin - return UI_From_Dint (Dint (Input)); + return UI_From_Int (Int (Input)); end UI_From_CC; - ------------------ - -- UI_From_Dint -- - ------------------ - - function UI_From_Dint (Input : Dint) return Uint is - begin - - if Dint (Min_Direct) <= Input and then Input <= Dint (Max_Direct) then - return Uint (Dint (Uint_Direct_Bias) + Input); - - -- For values of larger magnitude, compute digits into a vector and call - -- Vector_To_Uint. - - else - declare - Max_For_Dint : constant := 5; - -- Base is defined so that 5 Uint digits is sufficient to hold the - -- largest possible Dint value. - - V : UI_Vector (1 .. Max_For_Dint); - - Temp_Integer : Dint := Input; - - begin - for J in reverse V'Range loop - V (J) := Int (abs (Temp_Integer rem Dint (Base))); - Temp_Integer := Temp_Integer / Dint (Base); - end loop; - - return Vector_To_Uint (V, Input < Dint'(0)); - end; - end if; - end UI_From_Dint; - ----------------- -- UI_From_Int -- ----------------- @@ -2188,11 +2161,7 @@ package body Uintp is Y := Uint_0; loop - UI_Div_Rem - (U, V, - Quotient => Q, Remainder => R, - Discard_Quotient => False, - Discard_Remainder => False); + UI_Div_Rem (U, V, Quotient => Q, Remainder => R); U := V; V := R; @@ -2229,12 +2198,15 @@ package body Uintp is function UI_Mul (Left : Uint; Right : Uint) return Uint is begin - -- Simple case of single length operands + -- Case where product fits in the range of a 32-bit integer - if Direct (Left) and then Direct (Right) then + if Int (Left) <= Int (Uint_Max_Simple_Mul) + and then + Int (Right) <= Int (Uint_Max_Simple_Mul) + then return - UI_From_Dint - (Dint (Direct_Val (Left)) * Dint (Direct_Val (Right))); + UI_From_Int + (Int (Direct_Val (Left)) * Int (Direct_Val (Right))); end if; -- Otherwise we have the general case (Algorithm M in Knuth) @@ -2557,9 +2529,7 @@ package body Uintp is pragma Warnings (Off, Quotient); begin UI_Div_Rem - (Left, Right, Quotient, Remainder, - Discard_Quotient => True, - Discard_Remainder => False); + (Left, Right, Quotient, Remainder, Discard_Quotient => True); return Remainder; end; end UI_Rem; diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads index 492498d6cf2..d222c52c12f 100644 --- a/gcc/ada/uintp.ads +++ b/gcc/ada/uintp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -233,9 +233,6 @@ package Uintp is -- given Modulo (uses Euclid's algorithm). Note: the call is considered -- to be erroneous (and the behavior is undefined) if n is not invertible. - function UI_From_Dint (Input : Dint) return Uint; - -- Converts Dint value to universal integer form - function UI_From_Int (Input : Int) return Uint; -- Converts Int value to universal integer form @@ -404,7 +401,8 @@ private -- Base is defined to allow efficient execution of the primitive operations -- (a0, b0, c0) defined in the section "The Classical Algorithms" -- (sec. 4.3.1) of Donald Knuth's "The Art of Computer Programming", - -- Vol. 2. These algorithms are used in this package. + -- Vol. 2. These algorithms are used in this package. In particular, + -- the product of two single digits in this base fits in a 32-bit integer. Base_Bits : constant := 15; -- Number of bits in base value @@ -470,6 +468,11 @@ private Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80); Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128); + Uint_Max_Simple_Mul : constant := Uint_Direct_Bias + 2 ** 15; + -- If two values are directly represented and less than or equal to this + -- value, then we know the product fits in a 32-bit integer. This allows + -- UI_Mul to efficiently compute the product in this case. + type Save_Mark is record Save_Uint : Uint; Save_Udigit : Int; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 9e2b3c43f85..2121b7f20e4 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -595,7 +595,22 @@ begin if Ada_Version_Default = Ada_05 then Write_Line ("Ada 2005 mode (default)"); else - Write_Line ("Allow Ada 2005 extensions"); + Write_Line ("Enforce Ada 2005 restrictions"); end if; + -- Line for -gnat12 switch + + Write_Switch_Char ("12"); + + if Ada_Version_Default = Ada_12 then + Write_Line ("Ada 2012 mode (default)"); + else + Write_Line ("Allow Ada 2012 extensions"); + end if; + + -- Line for -gnat-p switch + + Write_Switch_Char ("-p"); + Write_Line ("Cancel effect of previous -gnatp switch"); + end Usage; diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb index 0772a494f12..e9aba4906eb 100644 --- a/gcc/ada/vms_conv.adb +++ b/gcc/ada/vms_conv.adb @@ -2274,9 +2274,15 @@ package body VMS_Conv is New_Line; while Commands /= null loop - Put (Commands.Usage.all); - Set_Col (53); - Put_Line (Commands.Unix_String.all); + + -- No usage for GNAT SYNC + + if Commands.Command /= Sync then + Put (Commands.Usage.all); + Set_Col (53); + Put_Line (Commands.Unix_String.all); + end if; + Commands := Commands.Next; end loop; diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index d25f7a34f1b..8454041abb1 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, 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- -- @@ -196,6 +196,14 @@ package VMS_Data is -- -- Add directories to the project search path. + S_Bind_ALI : aliased constant S := "/ALI_LIST " & + "-A"; + -- /NOALI_LIST (D) + -- /ALI_LIST + -- + -- Output full names of all the ALI files in the partition. The output is + -- written to SYS$OUTPUT. + S_Bind_Bind : aliased constant S := "/BIND_FILE=" & "ADA " & "-A " & @@ -385,7 +393,7 @@ package VMS_Data is -- /NOOBJECT_LIST (D) -- /OBJECT_LIST -- - -- Output full names of all the object files that must be linker to + -- Output full names of all the object files that must be linked to -- provide the Ada component of the program. The output is written to -- SYS$OUTPUT. @@ -669,6 +677,7 @@ package VMS_Data is Bind_Switches : aliased constant Switches := (S_Bind_Add 'Access, + S_Bind_ALI 'Access, S_Bind_Bind 'Access, S_Bind_Build 'Access, S_Bind_Current 'Access, @@ -1145,6 +1154,13 @@ package VMS_Data is -- of the directory specified in the project file. If the subdirectory -- does not exist, it is created automatically. + S_Clean_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + S_Clean_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) @@ -1170,7 +1186,8 @@ package VMS_Data is S_Clean_Recurs 'Access, S_Clean_Search 'Access, S_Clean_Subdirs'Access, - S_Clean_Verbose'Access); + S_Clean_Verbose'Access, + S_Clean_USL 'Access); ------------------------------- -- Switches for GNAT COMPILE -- @@ -1210,7 +1227,13 @@ package VMS_Data is "-gnat05"; -- /05 (D) -- - -- Allows GNAT to recognize all implemented proposed Ada 2005 + -- Allows GNAT to recognize the full range of Ada 2005 constructs. + + S_GCC_Ada_12 : aliased constant S := "/12 " & + "-gnat12"; + -- /05 (D) + -- + -- Allows GNAT to recognize all implemented proposed Ada 2012 -- extensions. See features file for list of implemented features. S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & @@ -1253,7 +1276,9 @@ package VMS_Data is "STACK " & "-fstack-check " & "SUPPRESS_ALL " & - "-gnatp"; + "-gnatp " & + "UNSUPPRESS_ALL " & + "-gnat-p"; -- /NOCHECKS -- /CHECKS[=(keyword[,...])] -- @@ -1267,47 +1292,50 @@ package VMS_Data is -- You may specify one or more of the following keywords to the /CHECKS -- qualifier to modify this behavior: -- - -- DEFAULT The behavior described above. This is the default - -- if the /CHECKS qualifier is not present on the - -- command line. Same as /NOCHECKS. - -- - -- OVERFLOW Enables overflow checking for integer operations and - -- checks for access before elaboration on subprogram - -- calls. This causes GNAT to generate slower and larger - -- executable programs by adding code to check for both - -- overflow and division by zero (resulting in raising - -- "Constraint_Error" as required by Ada semantics). - -- Similarly, GNAT does not generate elaboration check - -- by default, and you must specify this keyword to - -- enable them. - -- - -- Note that this keyword does not affect the code - -- generated for any floating-point operations; it - -- applies only to integer operations. For floating-point, - -- GNAT has the "Machine_Overflows" attribute set to - -- "False" and the normal mode of operation is to generate - -- IEEE NaN and infinite values on overflow or invalid - -- operations (such as dividing 0.0 by 0.0). - -- - -- ELABORATION Enables dynamic checks for access-before-elaboration - -- on subprogram calls and generic instantiations. - -- - -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no - -- effect and are ignored. This keyword causes "Assert" - -- and "Debug" pragmas to be activated, as well as - -- "Check", "Precondition" and "Postcondition" pragmas. - -- - -- SUPPRESS_ALL Suppress all runtime checks as though you have "pragma - -- Suppress (all_checks)" in your source. Use this switch - -- to improve the performance of the code at the expense - -- of safety in the presence of invalid data or program - -- bugs. - -- - -- DEFAULT Suppress the effect of any option OVERFLOW or - -- ASSERTIONS. - -- - -- FULL (D) Similar to OVERFLOW, but suppress the effect of any - -- option ELABORATION or SUPPRESS_ALL. + -- DEFAULT The behavior described above. This is the default + -- if the /CHECKS qualifier is not present on the + -- command line. Same as /NOCHECKS. + -- + -- OVERFLOW Enables overflow checking for integer operations and + -- checks for access before elaboration on subprogram + -- calls. This causes GNAT to generate slower and larger + -- executable programs by adding code to check for both + -- overflow and division by zero (resulting in raising + -- "Constraint_Error" as required by Ada semantics). + -- Similarly, GNAT does not generate elaboration check + -- by default, and you must specify this keyword to + -- enable them. + -- + -- Note that this keyword does not affect the code + -- generated for any floating-point operations; it + -- applies only to integer operations. For the case of + -- floating-point, GNAT has the "Machine_Overflows" + -- attribute set to "False" and the normal mode of + -- operation is to generate IEEE NaN and infinite values + -- on overflow or invalid operations (such as dividing + -- 0.0 by 0.0). + -- + -- ELABORATION Enables dynamic checks for access-before-elaboration + -- on subprogram calls and generic instantiations. + -- + -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no + -- effect and are ignored. This keyword causes "Assert" + -- and "Debug" pragmas to be activated, as well as + -- "Check", "Precondition" and "Postcondition" pragmas. + -- + -- SUPPRESS_ALL Suppress all runtime checks as though you have + -- "pragma Suppress (all_checks)" in your source. Use + -- this switch to improve the performance of the code at + -- the expense of safety in the presence of invalid data + -- or program bugs. + -- + -- UNSUPPRESS_ALL Cancels effect of previous SUPPRESS_ALL. + -- + -- DEFAULT Suppress the effect of any option OVERFLOW or + -- ASSERTIONS. + -- + -- FULL (D) Similar to OVERFLOW, but suppress the effect of any + -- option ELABORATION or SUPPRESS_ALL. -- -- These keywords only control the default setting of the checks. You -- may modify them using either "Suppress" (to remove checks) or @@ -3592,6 +3620,13 @@ package VMS_Data is -- HIGH A great number of messages are output, most of them not -- being useful for the user. + S_Elim_Nodisp : aliased constant S := "/NO_DISPATCH " & + "--no-elim-dispatch"; + -- /NONO_DISPATCH (D) + -- /NO_DISPATCH + -- + -- Do not generate pragmas for dispatching operations. + S_Elim_Project : aliased constant S := "/PROJECT_FILE=<" & "-P>"; -- /PROJECT_FILE=filename @@ -3625,14 +3660,14 @@ package VMS_Data is -- -- Duplicate all the output sent to Stderr into a default log file. - S_Elim_Logfile : aliased constant S := "/LOGFILE=@ " & + S_Elim_Logfile : aliased constant S := "/LOGFILE=@" & "-l@"; -- /LOGFILE=logfilename -- -- Duplicate all the output sent to Stderr into a specified log file. - S_Elim_Main : aliased constant S := "/MAIN=@ " & + S_Elim_Main : aliased constant S := "/MAIN=@" & "-main=@"; -- /MAIN=filename @@ -3704,6 +3739,7 @@ package VMS_Data is S_Elim_Logfile 'Access, S_Elim_Main 'Access, S_Elim_Mess 'Access, + S_Elim_Nodisp 'Access, S_Elim_Out 'Access, S_Elim_Project 'Access, S_Elim_Quiet 'Access, @@ -4838,6 +4874,13 @@ package VMS_Data is -- For example, -O -O2 is different than -O2 -O, but -g -O is equivalent -- to -O -g. + S_Make_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & + "--unchecked-shared-lib-imports"; + -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) + -- /UNCHECKED_SHARED_LIB_IMPORTS + -- + -- Allow shared library projects to import static library projects + S_Make_Unique : aliased constant S := "/UNIQUE " & "-u"; -- /NOUNIQUE (D) @@ -4915,6 +4958,7 @@ package VMS_Data is S_Make_Stand 'Access, S_Make_Subdirs 'Access, S_Make_Switch 'Access, + S_Make_USL 'Access, S_Make_Unique 'Access, S_Make_Use_Map 'Access, S_Make_Verbose 'Access); diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 95bdfa985d8..b75da1f8423 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, 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- -- @@ -395,7 +395,7 @@ package body Xr_Tabls is begin case Ref_Type is - when 'b' | 'c' | 'm' | 'r' | 'R' | 'i' | ' ' | 'x' => + when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' | 'i' | ' ' | 'x' => null; when 'l' | 'w' => @@ -419,7 +419,12 @@ package body Xr_Tabls is (Symbol_Length => 0, Symbol => "", Key => new String'(Key), - Decl => null, + Decl => new Reference_Record' + (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => null, + Next => null), Is_Parameter => True, Decl_Type => ' ', Body_Ref => null, @@ -458,7 +463,7 @@ package body Xr_Tabls is New_Ref.Next := Declaration.Body_Ref; Declaration.Body_Ref := New_Ref; - when 'r' | 'R' | 'i' | 'l' | ' ' | 'x' | 'w' => + when 'r' | 'R' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' => New_Ref.Next := Declaration.Ref_Ref; Declaration.Ref_Ref := New_Ref; diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index f4d0fc29a36..ed213569e92 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2010, 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- -- @@ -231,7 +231,7 @@ package body Xref_Lib is Line_Start := Index (Entity (File_Start .. Entity'Last), ":"); - -- Check if it was a disk:\directory item (for NT and OS/2) + -- Check if it was a disk:\directory item (for Windows) if File_Start = Line_Start - 1 and then Line_Start < Entity'Last @@ -508,6 +508,7 @@ package body Xref_Lib is when 'D' => return "decimal type"; when 'E' => return "enumeration type"; when 'F' => return "float type"; + when 'H' => return "abstract type"; when 'I' => return "integer type"; when 'M' => return "modular type"; when 'O' => return "fixed type"; @@ -523,7 +524,6 @@ package body Xref_Lib is when 'd' => return Param_String & "decimal object"; when 'e' => return Param_String & "enumeration object"; when 'f' => return Param_String & "float object"; - when 'h' => return "interface"; when 'i' => return Param_String & "integer object"; when 'm' => return Param_String & "modular object"; when 'o' => return Param_String & "fixed object"; @@ -535,6 +535,8 @@ package body Xref_Lib is when 'x' => return Param_String & "abstract procedure"; when 'y' => return Param_String & "abstract function"; + when 'h' => return "interface"; + when 'g' => return "macro"; when 'K' => return "package"; when 'k' => return "generic package"; when 'L' => return "statement label"; @@ -542,6 +544,7 @@ package body Xref_Lib is when 'N' => return "named number"; when 'n' => return "enumeration literal"; when 'q' => return "block label"; + when 'Q' => return "include file"; when 'U' => return "procedure"; when 'u' => return "generic procedure"; when 'V' => return "function"; @@ -557,7 +560,11 @@ package body Xref_Lib is -- have an unknown Abbrev value when others => - return "??? (" & Get_Type (Decl) & ")"; + if Is_Parameter (Decl) then + return "parameter"; + else + return "??? (" & Get_Type (Decl) & ")"; + end if; end case; end Get_Full_Type; @@ -1587,8 +1594,13 @@ package body Xref_Lib is File := Get_File_Ref (Arr (R)); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Arr (R), Full_Path_Name)); - Write_Str (F.all & ' '); - Free (F); + + if F = null then + Write_Str ("<unknown> "); + else + Write_Str (F.all & ' '); + Free (F); + end if; end if; Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R))); @@ -1637,8 +1649,14 @@ package body Xref_Lib is Write_Str (" Decl: "); F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Decl, Full_Path_Name)); - Print80 (F.all & ' '); - Free (F); + + if F = null then + Print80 ("<unknown> "); + else + Print80 (F.all & ' '); + Free (F); + end if; + Print_Ref (Get_Line (Decl), Get_Column (Decl)); Print_List |