diff options
Diffstat (limited to 'gcc/ada')
147 files changed, 7849 insertions, 1751 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f8d6489ac83..77fd4bf15d1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,11 +1,765 @@ +2011-11-24 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * s-taprop-tru64.adb (Create_Task): Use Unrestricted_Access. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * thread.c, s-oscons-tmplt.c: Generate __gnat_pthread_condattr_setup + only on platforms where this is required, as determined by + s-oscons.h. + +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch9.adb: No check on entry index if error on index. + +2011-11-23 Gary Dismukes <dismukes@adacore.com> + + * sem_ch6.adb (Analyze_Return_Statement): Improve error messages for + return statements nested inside an extended_return_statement. + * gcc-interface/Make-lang.in: Update dependencies. + * gcc-interface/Makefile.in (MISCLIB): Add -lutil for BSD targets. + +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_All_Ent): An incomplete type is not + frozen by a subprogram body that does not come from source. + +2011-11-23 Pascal Obry <obry@adacore.com> + + * s-oscons-tmplt.c: Add PTY_Library constant. It contains + the library for pseudo terminal support. + * g-exptty.ads: Add pseudo-terminal library into a Linker_Options + pragma. + +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch9.adb: No check on entry family index if generic. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * sem_ch9.adb, s-taprop.ads, s-taprop-hpux-dce.adb, s-taprop-irix.adb, + s-taprop-posix.adb, s-taprop-rtx.adb, s-taprop-solaris.adb, + s-taprop-tru64.adb, s-taprop-vxworks.adb: Move dependency on + System.OS_Constants from shared spec of + System.Tasking.Primitive_Operations to the specific body variants + that really require this dependency. + +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Analyze_Subprogram_Renaming_Declaration): + If the declaration has aspects, analyze them so they can be + properly rejected. + +2011-11-23 Hristian Kirtchev <kirtchev@adacore.com> + + * a-comutr.adb, a-coorma.adb, a-coorse.adb, a-convec.adb, a-cihase.adb, + a-cimutr.adb, a-coinve.adb, a-ciorma.adb, a-ciorse.adb, a-cobove.adb, + a-cohama.adb, a-cihama.adb, a-cidlli.adb, a-cdlili.adb, a-cbhama.adb, + a-cbhase.adb, a-cbmutr.adb, a-cborma.adb, a-cborse.adb, a-cbdlli.adb: + Add with and use clause for Ada.Finalization. Type + Iterator and Child_Iterator are now derived from Limited_Controlled. + (Finalize): New routine. + (Iterate): Add a renaming of counter Busy and + increment it. Update the return aggregate. + (Iterate_Children): Add a renaming of + counter Busy and increment it. Update the return aggregate. + (Iterate_Subtree): Add a renaming of counter Busy and increment + it. Update the return aggregate. + * a-cdlili.ads, a-cidlli.ads: Type List_Access is now a general access + type. + * a-cihama.ads: Type Map_Access is now a general access type. + * a-comutr.ads, a-cimutr.ads: Use type Natural for the two locks + associated with the tree. + * a-cohama.ads: Type Map_Access is now a general access type. + * a-coinve.ads, a-convec.ads: Type Vector_Access is now a general + access type. + * exp_ch5.adb (Expand_Iterator_Loop): Do not create a block + to wrap the loop as this is done at an earlier step, during + analysis. The declarations of the iterator and the cursor use + the usual Insert_Action mechanism when added into the tree. + * sem_ch5.adb (Analyze_Loop_Statement): Remove local constant + Loop_Statement and replace all respective uses by N. Add local + constant Loc. Preanalyze the loop iterator to discover whether + it is a container iterator and if it is, wrap the loop in a + block. This ensures that any controlled temporaries produced + by the iteration scheme share the same lifetime of the loop. + (Is_Container_Iterator): New routine. + (Is_Wrapped_In_Block): New routine. + (Pre_Analyze_Range): Move spec and body to the library level. + +2011-11-23 Sergey Rybin <rybin@adacore.com frybin> + + * gnat_ugn.texi, vms_data.ads: Add documentation for new gnatpp option + that controls casing of type and subtype names. + +2011-11-23 Yannick Moy <moy@adacore.com> + + * sem_ch3.adb: Minor addition of comments. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * prj-part.adb (Extension_Withs): New global variable, + contains the head of the list of WITH clauses from the EXTENDS + ALL projects for which virtual packages are being created. + (Look_For_Virtual_Projects_For): When recursing through + an EXTENDS ALL, add the WITH clauses of the extending + project to Extension_Withs. When adding a project to the + Virtual_Hash, record the associated Extension_Withs list. + (Create_Virtual_Extending_Project): Add a copy of the appropriate + Extension_Withs to the virtual project. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * mlib-tgt-specific-vxworks.adb: Minor reformatting. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * Make-generated.in (Sdefault.Target_Name): Set to + $(target_noncanonical) instead of $(target) for consistency. + +2011-11-23 Matthew Heaney <heaney@adacore.com> + + * a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb (Iterator): Declared + Iterator type as limited (First, Last): Cursor return value + depends on iterator node value (Iterate): Use start position as + iterator node value (Next, Previous): Forward to corresponding + cursor-based operation. + +2011-11-23 Matthew Heaney <heaney@adacore.com> + + * a-coorse.ads, a-ciorse.ads, a-cborse.ads (Set_Iterator_Interfaces): + Renamed from Ordered_Set_Iterator_Interfaces. + * a-coorse.adb, a-ciorse.adb, a-cborse.adb (Iterator): Declared + Iterator type as limited (First, Last): Cursor return value + depends on iterator node value (Iterate): Use start position as + iterator node value (Next, Previous): Forward to corresponding + cursor-based operation. + * a-cohase.ads, a-cohase.adb: Implemented forward iterator. + * a-cihase.adb, a-cbhase.adb (Iterator): Removed unnecessary + node component (First, Next): Forward call to corresponding + cursor-based operation (Iterate): Representation of iterator no + longer has node component + +2011-11-23 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_intr.adb (Expand_Unc_Deallocation): Ensure that the + dereference has a proper type before the side effect removal + mechanism kicks in. + * sem_ch3.adb (Analyze_Subtype_Declaration): Handle a rare case + where the base type of the subtype is a private itype created + to act as the partial view of a constrained record type. This + scenario manifests with equivalent class-wide types for records + with unknown discriminants. + +2011-11-23 Jerome Guitton <guitton@adacore.com> + + * s-osprim-vxworks.adb (Clock): Use Clock_RT_Ada. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * s-oscons-tmplt.c: Fix unbalanced preprocessor directives Minor + reformatting/reorganization. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * g-htable.ads: Remove old comments. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * exp_imgv.adb: Minor reformatting. + +2011-11-23 Robert Dewar <dewar@adacore.com> + + * sem_ch9.adb (Analyze_Entry_Declaration): Check for entry + family bounds out of range. + +2011-11-23 Matthew Heaney <heaney@adacore.com> + + * a-cohama.adb, a-cihama.adb, a-cbhama.adb (Iterator): Declare + type as limited, and remove node component. + (First, Next): Forward call to corresponding cursor-based operation. + (Iterate): Representation of iterator no longer has node component. + +2011-11-23 Yannick Moy <moy@adacore.com> + + * exp_util.adb: Revert previous change to remove side-effects in Alfa + mode, which is not the correct thing to do for renamings. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * s-osinte-hpux.ads, s-taprop-vxworks.adb, s-taprop-tru64.adb, + s-osinte-vxworks.ads, s-osinte-aix.ads, s-osinte-lynxos.ads, + s-osinte-solaris-posix.ads, s-taprop-solaris.adb, a-exetim-posix.adb, + s-osinte-irix.ads, s-osinte-solaris.ads, s-oscons-tmplt.c, + s-taprop-irix.adb, s-osinte-hpux-dce.ads, Makefile.rtl, + s-osinte-tru64.ads, s-osinte-darwin.ads, s-taprop.ads, + s-osinte-freebsd.ads, s-osinte-lynxos-3.ads, s-taprop-hpux-dce.adb, + s-taprop-posix.adb: Remove hard-coded clock ids; + instead, generate them in System.OS_Constants. + (System.OS_Constants.CLOCK_RT_Ada): New constant denoting the + id of the clock providing Ada.Real_Time.Monotonic_Clock. + * thread.c: New file. + (__gnat_pthread_condattr_setup): New function. For platforms where + CLOCK_RT_Ada is not CLOCK_REALTIME, set appropriate condition + variable attribute. + +2011-11-23 Yannick Moy <moy@adacore.com> + + * sem_ch3.adb: Restore the use of Expander_Active instead of + Full_Expander_Active, so that the evaluation is forced in Alfa + mode too. Otherwise, we end up with an unexpected insertion in a + place where it is not supposed to happen, on default parameters + of a call. + +2011-11-23 Thomas Quinot <quinot@adacore.com> + + * prj-pp.adb, prj-pp.ads: Minor new addition: wrapper procedure "wpr" + for Pretty_Print, for use from within gdb. + +2011-11-23 Ed Schonberg <schonberg@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop): Wrap the expanded loop + and the cursor declarations in a block, so that the loop variable + is local to the construct. + +2011-11-23 Matthew Heaney <heaney@adacore.com> + + * a-coorma.ads, a-ciorma.ads, a-cborma.ads (Iterate): Returns + type Reversible_Iterator'Class. + * a-coorma.adb, a-ciorma.adb, a-cborma.adb (Iterator): + Declare type as limited. + (First, Last): Return value depends on iterator's start node value. + (Next, Previous): Call corresponding Cursor-based operation. + (Iterate): Indicate whether complete or partial iteration + +2011-11-23 Robert Dewar <dewar@adacore.com> + + * errout.adb: Minor reformattin (Finalize): Take templates into + account for warning suppression. + * errout.ads (Set_Specific_Warning_Off): Add Used parameter. + * erroutc.adb: Minor reformatting (Finalize): Take generic + templates into account for warning suppress. + * erroutc.ads (Set_Specific_Warning_Off): Add Used parameter. + * sem_prag.adb: Minor reformatting (Analyze_Pragma, + case Warnings): Provide Used parameter in call to + Set_Specific_Warnings_Off (to deal with generic template case). + +2011-11-23 Pascal Obry <obry@adacore.com> + + * sem_prag.adb (Process_Convention): Better error message for + stdcall convention on dispatching calls. + +2011-11-23 Gary Dismukes <dismukes@adacore.com> + + * sem_ch4.adb, sem_ch13.adb: Minor reformatting. + +2011-11-23 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Expand_Simple_Function_Return): Add missing + implicit type conversion when the returned object is allocated + in the secondary stack and the type of the returned object is + an interface. Done to force generation of displacement of the + "this" pointer. + +2011-11-23 Pascal Obry <obry@adacore.com> + + * impunit.adb: Add g-exptty and g-tty units. + +2011-11-23 Robert Dewar <dewar@adacore.com> + + * exp_imgv.adb: Minor code reorganization (use Make_Temporary). + +2011-11-23 Robert Dewar <dewar@adacore.com> + + * exp_util.adb, par-ch6.adb, sem_res.adb, par-util.adb: Minor + reformatting. + +2011-11-23 Yannick Moy <moy@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Specifications): Place error on + line of precondition/ postcondition/invariant. + +2011-11-23 Pascal Obry <obry@adacore.com> + + * g-exptty.ads, g-exptty.adb, g-tty.ads, g-tty.adb, + terminals.c: New files. + Makefile.rtl: Add these new files. + * gnat_rm.texi: Add documentation for GNAT.Expect.TTY. + * gcc-interface/Makefile.in: Add g-exptty, g-tty, terminals.o + * gcc-interface/Make-lang.in: Update dependencies. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * exp_imgv.adb (Expand_Width_Attribute): Handle case of Discard_Names. + * sem_attr.adb (Eval_Attribute, case Width): Ditto. + +2011-11-21 Thomas Quinot <quinot@adacore.com> + + * sinfo.ads: Minor reformatting. + +2011-11-21 Yannick Moy <moy@adacore.com> + + * exp_util.adb: Minor reformatting. Update comments. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * exp_prag.adb, exp_util.adb, sinfo.ads, sem_res.adb, s-stposu.adb, + sem_attr.adb, s-stposu.ads, s-taprop-solaris.adb, s-taprop-irix.adb, + sem_ch6.adb: Minor reformatting. + +2011-11-21 Arnaud Charlet <charlet@adacore.com> + + * s-taprop-irix.adb, s-taprop-solaris.adb (Create_Task): Use + Unrestricted_Access to deal with fact that we properly detect the + error if Access is used. + * gcc-interface/Make-lang.in: Update dependencies. + +2011-11-21 Yannick Moy <moy@adacore.com> + + * exp_prag.adb (Expand_Pragma_Check): Place error on first character + of expression. + * sem_res.adb (Resolve_Short_Circuit): Place error on first + character of expression. + +2011-11-21 Yannick Moy <moy@adacore.com> + + * exp_util.adb (Remove_Side_Effects): Do nothing in Alfa mode. + +2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference, case + Max_Size_In_Storage_Elements): Account for the size of the + hidden list header which precedes controlled objects allocated + on the heap. + * rtsfind.ads: Add RE_Header_Size_With_Padding to the runtime + tables. + * sinfo.adb (Header_Size_Added): New routine. + (Set_Header_Size_Added): New routine. + * sinfo.ads: Add flag Controlled_Header_Added along with + associated comment. + (Header_Size_Added): New inlined routine. + (Set_Header_Size_Added): New inlined routine. + * s-stposu.adb (Allocate_Any_Controlled): Use + Header_Size_With_Padding to calculate the proper + size of the header. + (Deallocate_Any_Controlled): Use + Header_Size_With_Padding to calculate the proper size + of the header. (Header_Size_With_Padding): New routine. + (Nearest_Multiple_Rounded_Up): Removed along with its uses. + * s-stposu.ads (Header_Size_With_Padding): New routine. + +2011-11-21 Ed Schonberg <schonberg@adacore.com> + + * aspects.adb: Aspect specifications are allowed on renaming + declarations + * par-ch6.adb (P_Subprogram): Parse aspect specifications in a + subprogram renaming declaration + +2011-11-21 Tristan Gingold <gingold@adacore.com> + + * env.c: Remove unused declaration. + +2011-11-21 Pascal Obry <obry@adacore.com> + + * s-os_lib.ads: Minor style fix. + +2011-11-21 Pascal Obry <obry@adacore.com> + + * adaint.c (__gnat_dup2): When fd are stdout, stdin or stderr and + identical, do nothing on Windows XP. + +2011-11-21 Yannick Moy <moy@adacore.com> + + * sem_ch3.adb (Constrain_Index, Process_Range_Expr_In_Decl): + Use Full_Expander_Active instead of Expander_Active to control + the forced evaluation of expressions for the sake of generating + checks. + +2011-11-21 Thomas Quinot <quinot@adacore.com> + + * init.c: On FreeBSD, stack checking failures may raise SIGBUS. + +2011-11-21 Tristan Gingold <gingold@adacore.com> + + * sysdep.c (mode_read_text, mode_write_text, mode_append_text, + mode_read_binary, mode_write_binary, mode_append_binary, + mode_read_text_plus, mode_write_text_plus, mode_append_text_plus, + mode_read_binary_plus, mode_write_binary_plus, + mode_append_binary_plus): Remove unused declarations. + +2011-11-21 Yannick Moy <moy@adacore.com> + + * gnat_rm.texi: Minor rewording. + +2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_imgv.adb (Expand_Width_Attribute): Emit + an error message rather than a warning when pragma Discard_Names + prevents the computation of 'Width. Do not emit an error through + the use of RE_Null. + +2011-11-21 Javier Miranda <miranda@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Add + implicit type conversion when the type of the allocator is an + interface. Done to force generation of displacement of the "this" + pointer when required. + +2011-11-21 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads, sinfo.adb: Corresponding_Spec applies to expression + functions, and is set when the expression is a completion of a + previous declaration. + * sem_ch6.adb (Analyze_Expression_Function): To determine properly + whether an expression function completes a previous declaration, + use Find_Corresponding_Spec, as when analyzing a subprogram body. + +2011-11-21 Steve Baird <baird@adacore.com> + + * sem_util.adb (Deepest_Type_Access_Level): Improve comment. + (Type_Access_Level): Improve comment. + +2011-11-21 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/Makefile.in (INCLUDES_FOR_SUBDIR): Add $(fsrcdir) by + means of -iquote unconditionally. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor + reformatting. + +2011-11-21 Arnaud Charlet <charlet@adacore.com> + + * s-taprop-posix.adb (Create_Task): Use Unrestricted_Access + to deal with fact that we properly detect the error if Access + is used. + +2011-11-21 Steve Baird <baird@adacore.com> + + * sem_util.ads: Update comment describing function + Deepest_Access_Level. + * sem_util.adb (Deepest_Type_Access_Level): Return Int'Last for a + generic formal type. + (Type_Access_Level): Return library level + for a generic formal type. + * sem_attr.adb (Resolve_Attribute): Replace two Type_Access_Level + calls with calls to Deepest_Type_Access_Level. + * sem_ch3.adb (Analyze_Component_Declaration): replace a + Type_Access_Level call with a call to Deepest_Type_Access_Level. + * sem_res.adb (Resolve_Allocator.Check_Allocator_Discrim_Accessibility): + Replace three Type_Access_Level calls with calls to + Deepest_Type_Access_Level. + (Resolve_Allocator): Replace a Type_Access_Level call with a call to + Deepest_Type_Access_Level. + (Valid_Conversion.Valid_Array_Conversion): Replace a + Type_Access_Level call with a call to Deepest_Type_Access_Level. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb, s-taprop-vms.adb, opt.ads: Minor reformatting. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sinput.ads: Minor comment fix. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference, case First_Bit, + Last_Bit, Position): Handle 2005 case. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * s-atocou-builtin.adb (Decrement): Use Unrestricted_Access + to deal with fact that we properly detect the error if Access + is used. + (Increment): Same fix. + * s-taprop-linux.adb (Create_Task): Use Unrestricted_Access + to deal with fact that we properly detect the error if Access + is used. + * sem_util.adb (Is_Volatile_Object): Properly record that A.B is + volatile if the B component is volatile. This affects the check + for passing such a by reference volatile actual to a non-volatile + formal (which should be illegal) + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * freeze.adb (Freeze_Enumeration_Type): Make sure to set both + size and alignment for foreign convention enumeration types. + * layout.adb (Set_Elem_Alignment): Redo setting of alignment + when size is set. + +2011-11-21 Yannick Moy <moy@adacore.com> + + * checks.adb (Apply_Access_Check, Apply_Arithmetic_Overflow_Check, + Apply_Discriminant_Check, Apply_Divide_Check, + Apply_Selected_Length_Checks, Apply_Selected_Range_Checks, + Build_Discriminant_Checks, Insert_Range_Checks, Selected_Length_Checks, + Selected_Range_Checks): Replace reference to Expander_Active + with reference to Full_Expander_Active, so that expansion of + checks is not performed in Alfa mode + +2011-11-21 Tristan Gingold <gingold@adacore.com> + + * s-taprop-vms.adb (Create_Task): Use Unrestricted_Access to deal with + fact that we properly detect the error if Access is used. + +2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> + + * par-ch4.adb (P_Quantified_Expression): Add an Ada 2012 check. + +2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_imgv.adb: Add with and use clause for Errout. + (Expand_Width_Attribute): Emit a warning when in + configurable run-time mode to provide a better diagnostic message. + +2011-11-21 Hristian Kirtchev <kirtchev@adacore.com> + + * s-finmas.adb (Finalize): Add comment concerning double finalization. + +2011-11-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Access_Definition): If the access definition + is itself the return type of an access to function definition + which is ultimately the return type of an access to subprogram + declaration, its scope is the enclosing scope of the ultimate + access to subprogram. + +2011-11-21 Steve Baird <baird@adacore.com> + + * sem_res.adb (Valid_Conversion): If a conversion was legal + in the body of a generic, then the corresponding conversion is + legal in the expanded body of an instance of the generic. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sem_ch3.adb: Minor reformatting. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * s-utf_32.adb (Is_UTF_32_Line_Terminator): Recognize NEL as + line terminator. + * sinput.ads: Add section on Handling of Source Line Terminators. + * types.ads (Line_Terminator): Adjust comments. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * frontend.adb (Frontend): Capture restrictions from config files + * lib-load.adb (Load_Unit): Save/set/restore restriction pragma + information + * lib-xref.adb (Generate_Reference): Fix handling of obsolescent + references. This was noticed during debugging, but it is not + known if it causes real bugs. + * restrict.ads, restrict.adb: New routines to save/set/restore + non-partition-wide restrictions. + * s-rident.ads: Comment changes for new handling of + No_Elaboration_Code + * sem.adb (Sem): Save/Set/Restore non-partition-wide restrictions + * sem_ch10.adb (Analyze_Compilation_Unit): Remove incomplete + attempt to save/restore non-partition-wide restrictions (now + this work is all done in Sem). + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): + Special handling for restriction No_Elaboration_Code. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * gnat_ugn.texi: Document new handling of restrictions pragmas. + +2011-11-21 Pascal Obry <obry@adacore.com> + + * s-taprop-linux.adb (Initialize_Lock): Do not allocate a cond + attribute as not needed. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb: Minor reformatting. + +2011-11-21 Pascal Obry <obry@adacore.com> + + * gnat_rm.texi: Document restriction for stdcall convention on + dispatching calls. + +2011-11-21 Pascal Obry <obry@adacore.com> + + * sem_prag.adb (Process_Convention): A dispatching call cannot + have a stdcall calling convention. + +2011-11-21 Pascal Obry <obry@adacore.com> + + * s-taprop-linux.adb (Initialize_Lock): Do not allocate a + mutex attribute as not needed. + (Initialize_TCB): Likewise. + (Initialize): Likewise. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sem_ch6.adb (Is_Public_Subprogram_For): New procedure + (Process_PPCs): Invariants only apply to public subprograms. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sem_util.adb, sem_util.ads, sem_attr.adb, restrict.adb, + restrict.ads: Fix for No_Implicit_Aliasing in the renames case. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * a-finali.ads: Use pragma Pure_12 for this unit + * aspects.adb: Add aspect Pure_12 + * aspects.ads: Add aspect Pure_12 + * opt.ads: Add note on Pure_12 + * par-prag.adb: Add dummy entry for Pure_12 + * sem_prag.adb: Implement Pure_12 pragma + * snames.ads-tmpl: Add Entry for Pure_12 + +2011-11-21 Sergey Rybin <rybin@adacore.com frybin> + + * vms_data.ads: Add qualifiers for new gnatpp options + '--call_threshold' and '--par_threshold". + * gnat_ugn.texi: Add description for new gnatpp options + '--call_threshold' and '--par_threshold". + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * lib.ads: Minor reformatting. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * lib-load.ads: Add comment. + +2011-11-21 Gary Dismukes <dismukes@adacore.com> + + * sem_elab.adb: Minor reformatting + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb: Minor reformatting. + +2011-11-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Check_Formal_Package_Instance): If a formal + subprogram of the formal package is covered by an others + association with a box initialization, no check is needed + against the actual in the instantiation of the formal package. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * sem_elab.adb (Check_Internal_Call_Continue): Suppress junk + elab warning from within precondition/postcondition etc. + +2011-11-21 Ed Schonberg <schonberg@adacore.com> + + * exp_ch6.adb (Expand_Actuals): In Ada 2012, a function call + with out parameters may generate assignments to force constraint + checks. These checks must be properly placed in the code after the + declaration or statement that contains the call. + +2011-11-21 Fedor Rybin <frybin@adacore.com> + + * gnat_ugn.texi: Adding info on current gnattest limitations an + support of -X option. + +2011-11-21 Robert Dewar <dewar@adacore.com> + + * a-cfdlli.adb, a-cbdlli.adb: Minor reformatting. + +2011-11-20 Robert Dewar <dewar@adacore.com> + + * exp_ch6.adb, exp_util.adb: Minor reformatting + +2011-11-20 Eric Botcazou <ebotcazou@adacore.com> + + * sinfo.ads (Reference): Document that it is OK to set + Is_Known_Non_Null on a temporary initialized to a N_Reference + node. + +2011-11-20 Matthew Heaney <heaney@adacore.com> + + * a-cbdlli.adb, a-cfdlli.adb (Move): Set Last component to 0 + for Source list. + +2011-11-20 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Make_Build_In_Place_Call_In_Assignment): + Declare NEW_EXPR local variable and attach the + temporary to it. Set Is_Known_Non_Null on the temporary. + (Make_Build_In_Place_Call_In_Object_Declaration): Likewise. + * exp_util.adb (Remove_Side_Effects): Set Is_Known_Non_Null on + the temporary created to hold the 'Reference of the expression, + if any. + * checks.adb (Install_Null_Excluding_Check): Bail out for the + Get_Current_Excep.all.all idiom generated by the expander. + +2011-11-20 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (struct language_function): Add GNAT_RET. + (f_gnat_ret): New macro. + (struct nrv_data): Add GNAT_RET. + (finalize_nrv_unc_r): New helper function. + (finalize_nrv): Add GNAT_RET parameter. Copy it into DATA. If the + function returns unconstrained, use finalize_nrv_unc_r as callback. + (return_value_ok_for_nrv_p): Test the alignment of RET_OBJ only if + RET_OBJ is non-null. + (Subprogram_Body_to_gnu): Pass GNAT_RET to finalize_nrv. + (gnat_to_gnu) <N_Return_Statement>: In the return-unconstrained case, + if optimization is enabled, record candidates for the Named Return + Value optimization. + +2011-11-20 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.c (Subprogram_Body_to_gnu): Add comment. + (gnat_to_gnu) <N_Return_Statement>: Add 'else' to avoid doing a useless + test. Tweak default case. + <N_Goto_Statement>: Use better formatting. + * gcc-interface/utils2.c (maybe_wrap_malloc): Use INIT_EXPR instead of + MODIFY_EXPR to initialize the storage. + (build_allocator): Likewise. + +2011-11-20 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>: Adjust + call to components_to_record. + (components_to_record): Add FIRST_FREE_POS parameter. For the variant + part, reuse enclosing union even if there is a representation clause + on the Unchecked_Union. If there is a variant part, compute the new + first free position, if any. Adjust call to self. Use a single field + directly only if it hasn't got a representation clause or is placed at + offset zero. Create the variant part at offset 0 if all the fields + down to this level have a rep clause. Do not chain the variant part + immediately and adjust downstream. + Do not test ALL_REP before moving the fields without rep clause to the + previous level. Call create_rep_part to create the REP part and force + a minimum size on it if necessary. Do not chain it immediately. + Create a fake REP part if there are fields without rep clause that need + to be laid out starting from FIRST_FREE_POS. + At the end, chain the REP part and then the variant part. + (create_rep_part): New function. + (get_rep_part): Minor tweak. + * gcc-interface/utils.c (tree_code_for_record_type): Minor tweak. + +2011-11-18 Iain Sandoe <iains@gcc.gnu.org> + + PR target/50678 + * init.c (__gnat_error_handler) [Darwin]: Move workaround to the + bug filed as radar #10302855 from __gnat_error_handler to... + (__gnat_adjust_context_for_raise) [Darwin]: ...here. New function. + (HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE) [Darwin]: Define. + +2011-11-18 Tristan Gingold <gingold@adacore.com> + Iain Sandoe <iains@gcc.gnu.org> + + PR target/49992 + * mlib-tgt-specific-darwin.adb (Archive_Indexer_Options): Remove. + * gcc-interface/Makefile.in (darwin): Remove ranlib special-casing. + 2011-11-12 Iain Sandoe <iains@gcc.gnu.org> * gcc-interface/Makefile.in (stamp-gnatlib-$(RTSDIR)): Don't link s-oscons.ads. (OSCONS_CPP, OSCONS_EXTRACT): New. - (./bldtools/oscons/xoscons): New Target. - ($(RTSDIR)/s-oscons.ads): New Target. - (gnatlib): Depend on $(RTSDIR)/s-oscons.ads. + (./bldtools/oscons/xoscons): New target. + ($(RTSDIR)/s-oscons.ads): Likewise. + (gnatlib): Depend on $(RTSDIR)/s-oscons.ads. * gcc-interface/Make-lang.in (ada/s-oscons.ads) Remove as dependency. * Make-generated.in: Remove machinery to generate xoscons and ada/s-oscons.ads. diff --git a/gcc/ada/Make-generated.in b/gcc/ada/Make-generated.in index ac52e491eeb..833d47f2582 100644 --- a/gcc/ada/Make-generated.in +++ b/gcc/ada/Make-generated.in @@ -72,7 +72,7 @@ $(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile $(ECHO) " S0 : constant String := \"$(prefix)/\";" >>tmp-sdefault.adb $(ECHO) " S1 : constant String := \"$(ADA_INCLUDE_DIR)/\";" >>tmp-sdefault.adb $(ECHO) " S2 : constant String := \"$(ADA_RTL_OBJ_DIR)/\";" >>tmp-sdefault.adb - $(ECHO) " S3 : constant String := \"$(target)/\";" >>tmp-sdefault.adb + $(ECHO) " S3 : constant String := \"$(target_noncanonical)/\";" >>tmp-sdefault.adb $(ECHO) " S4 : constant String := \"$(libsubdir)/\";" >>tmp-sdefault.adb $(ECHO) " function Include_Dir_Default_Name return String_Ptr is" >>tmp-sdefault.adb $(ECHO) " begin" >>tmp-sdefault.adb diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 50e8a96a3d3..5c3e307f713 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -75,7 +75,9 @@ GNATRTL_TASKING_OBJS= \ s-tpoben$(objext) \ s-tpobop$(objext) \ s-tposen$(objext) \ - s-tratas$(objext) $(EXTRA_GNATRTL_TASKING_OBJS) + s-tratas$(objext) \ + thread$(objext) \ + $(EXTRA_GNATRTL_TASKING_OBJS) # Objects needed for non-tasking. GNATRTL_NONTASKING_OBJS= \ @@ -404,6 +406,7 @@ GNATRTL_NONTASKING_OBJS= \ g-except$(objext) \ g-exctra$(objext) \ g-expect$(objext) \ + g-exptty$(objext) \ g-flocon$(objext) \ g-heasor$(objext) \ g-hesora$(objext) \ @@ -450,6 +453,7 @@ GNATRTL_NONTASKING_OBJS= \ g-timsta$(objext) \ g-traceb$(objext) \ g-trasym$(objext) \ + g-tty$(objext) \ g-u3spch$(objext) \ g-utf_32$(objext) \ g-wispch$(objext) \ diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index e1f7725d5cd..22000b3c7e4 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -27,15 +27,20 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; package body Ada.Containers.Bounded_Doubly_Linked_Lists is - type Iterator is new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Count_Type; + + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Count_Type; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -493,6 +498,22 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is return Position.Container.Nodes (Position.Node).Element; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -544,10 +565,23 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function First (Object : Iterator) return Cursor is begin - if Object.Container = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Doubly_Linked_Lists.First (Object.Container.all); else - return (Object.Container, Object.Container.First); + return Cursor'(Object.Container, Object.Node); end if; end First; @@ -1050,9 +1084,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Count_Type := Container.First; begin @@ -1075,14 +1107,28 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'class + return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - if Container.Length = 0 then - return Iterator'(null, Count_Type'First); - else - return Iterator'(Container'Unrestricted_Access, Container.First); - end if; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is 0 (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -1090,9 +1136,48 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is Start : Cursor) return List_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unrestricted_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong list"; + end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is positive (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -1110,10 +1195,23 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is function Last (Object : Iterator) return Cursor is begin - if Object.Container = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Doubly_Linked_Lists.Last (Object.Container.all); else - return (Object.Container, Object.Container.Last); + return Cursor'(Object.Container, Object.Node); end if; end Last; @@ -1164,18 +1262,66 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is "attempt to tamper with cursors of Source (list is busy)"; end if; + -- Clear target, note that this checks busy bits of Target + Clear (Target); - while Source.Length > 0 loop + while Source.Length > 1 loop + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last /= Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy first element from Source to Target + X := Source.First; Append (Target, N (X).Element); + -- Unlink first node of Source + Source.First := N (X).Next; N (Source.First).Prev := 0; Source.Length := Source.Length - 1; + + -- The representation invariants for Source have been restored. It is + -- now safe to free the unlinked node, without fear of corrupting the + -- active links of Source. + + -- Note that the algorithm we use here models similar algorithms used + -- in the unbounded form of the doubly-linked list container. In that + -- case, Free is an instantation of Unchecked_Deallocation, which can + -- fail (because PE will be raised if controlled Finalize fails), so + -- we must defer the call until the last step. Here in the bounded + -- form, Free merely links the node we have just "deallocated" onto a + -- list of inactive nodes, so technically Free cannot fail. However, + -- for consistency, we handle Free the same way here as we do for the + -- unbounded form, with the pessimistic assumption that it can fail. + Free (Source, X); end loop; + + if Source.Length = 1 then + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last = Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy element from Source to Target + + X := Source.First; + Append (Target, N (X).Element); + + -- Unlink node of Source + + Source.First := 0; + Source.Last := 0; + Source.Length := 0; + + -- Return the unlinked node to the free store + + Free (Source, X); + end if; end Move; ---------- @@ -1198,6 +1344,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is declare Nodes : Node_Array renames Position.Container.Nodes; Node : constant Count_Type := Nodes (Position.Node).Next; + begin if Node = 0 then return No_Element; @@ -1211,14 +1358,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Object : Iterator; Position : Cursor) return Cursor is - Nodes : Node_Array renames Position.Container.Nodes; - Node : constant Count_Type := Nodes (Position.Node).Next; begin - if Position.Node = Object.Container.Last then + if Position.Container = null then return No_Element; - else - return (Object.Container, Node); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong list"; + end if; + + return Next (Position); end Next; ------------- @@ -1267,14 +1417,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is (Object : Iterator; Position : Cursor) return Cursor is - Nodes : Node_Array renames Position.Container.Nodes; - Node : constant Count_Type := Nodes (Position.Node).Prev; begin - if Position.Node = 0 then + if Position.Container = null then return No_Element; - else - return (Object.Container, Node); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong list"; + end if; + + return Previous (Position); end Previous; ------------------- diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index d7c75d44aaf..471193079b5 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -34,15 +34,18 @@ with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Maps is - type Iterator is new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - Node : Count_Type; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; @@ -393,6 +396,22 @@ package body Ada.Containers.Bounded_Hashed_Maps is HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -424,14 +443,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is end First; function First (Object : Iterator) return Cursor is - M : constant Map_Access := Object.Container; - N : constant Count_Type := HT_Ops.First (M.all); begin - if N = 0 then - return No_Element; - else - return Cursor'(Object.Container.all'Unchecked_Access, N); - end if; + return Object.Container.First; end First; ----------------- @@ -656,7 +669,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; -- Start of processing for Iterate @@ -675,12 +688,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is end Iterate; function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - Node : constant Count_Type := HT_Ops.First (Container); - It : constant Iterator := (Container'Unrestricted_Access, Node); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- @@ -770,11 +788,16 @@ package body Ada.Containers.Bounded_Hashed_Maps is Position : Cursor) return Cursor is begin - if Position.Node = 0 then + if Position.Container = null then return No_Element; - else - return (Object.Container, Next (Position).Node); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); end Next; ------------------- diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb index 97a765a6839..cfefc73b6c1 100644 --- a/gcc/ada/a-cbhase.adb +++ b/gcc/ada/a-cbhase.adb @@ -34,16 +34,20 @@ with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Hashed_Sets is - type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record Container : Set_Access; - Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -570,6 +574,22 @@ package body Ada.Containers.Bounded_Hashed_Sets is HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -596,10 +616,8 @@ package body Ada.Containers.Bounded_Hashed_Sets is end First; overriding function First (Object : Iterator) return Cursor is - Node : constant Count_Type := HT_Ops.First (Object.Container.all); begin - return (if Node = 0 then No_Element - else Cursor'(Object.Container, Node)); + return Object.Container.First; end First; ----------------- @@ -890,7 +908,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; -- Start of processing for Iterate @@ -909,9 +927,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class is + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container'Unrestricted_Access, First (Container)); + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access); end Iterate; ------------ @@ -982,12 +1007,16 @@ package body Ada.Containers.Bounded_Hashed_Sets is Position : Cursor) return Cursor is begin + if Position.Container = null then + return No_Element; + end if; + if Position.Container /= Object.Container then raise Program_Error with - "Position cursor designates wrong set"; + "Position cursor of Next designates wrong set"; end if; - return (if Position.Node = 0 then No_Element else Next (Position)); + return Next (Position); end Next; ------------- @@ -1599,7 +1628,7 @@ package body Ada.Containers.Bounded_Hashed_Sets is begin if Node = 0 then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Container.Nodes (Node).Element; diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index 7ad2de4e62a..acda30f63c6 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -27,30 +27,38 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; + package body Ada.Containers.Bounded_Multiway_Trees is No_Node : constant Count_Type'Base := -1; - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; Position : Cursor) return Cursor; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next @@ -1229,6 +1237,34 @@ package body Ada.Containers.Bounded_Multiway_Trees is Right_Subtree => Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1732,8 +1768,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin if Container.Count = 0 then @@ -1758,13 +1793,19 @@ package body Ada.Containers.Bounded_Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1786,9 +1827,9 @@ package body Ada.Containers.Bounded_Multiway_Trees is end if; declare - NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Count_Type; + NN : Tree_Node_Array renames Parent.Container.Nodes; begin B := B + 1; @@ -1836,9 +1877,16 @@ package body Ada.Containers.Bounded_Multiway_Trees is Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1849,8 +1897,17 @@ package body Ada.Containers.Bounded_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1869,7 +1926,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all; - B : Integer renames T.Busy; + B : Natural renames T.Busy; begin B := B + 1; @@ -2259,8 +2316,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2529,7 +2586,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare NN : Tree_Node_Array renames Parent.Container.Nodes; - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Count_Type; begin @@ -3209,8 +3266,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb index 4cc2686bb22..141350956c1 100644 --- a/gcc/ada/a-cborma.adb +++ b/gcc/ada/a-cborma.adb @@ -35,19 +35,22 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); -with System; use type System.Address; +with Ada.Finalization; use Ada.Finalization; +with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Maps is - type Iterator is new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Count_Type; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Count_Type; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -551,6 +554,22 @@ package body Ada.Containers.Bounded_Ordered_Maps is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -579,12 +598,24 @@ package body Ada.Containers.Bounded_Ordered_Maps is end First; function First (Object : Iterator) return Cursor is - F : constant Count_Type := Object.Container.First; begin - if F = 0 then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Maps.First (Object.Container.all); else - return Cursor'(Object.Container.all'Unchecked_Access, F); + return Cursor'(Object.Container, Object.Node); end if; end First; @@ -886,22 +917,77 @@ package body Ada.Containers.Bounded_Ordered_Maps is end Iterate; function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class + (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := - (Container'Unrestricted_Access, Container.First); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is 0 (as is the case here), this means the iterator object + -- was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Container.First) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Map; Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'class + return Map_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unrestricted_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + -- Iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong map"; + end if; + + pragma Assert (Vet (Container, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is positive (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. (Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration.) + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- @@ -935,12 +1021,24 @@ package body Ada.Containers.Bounded_Ordered_Maps is end Last; function Last (Object : Iterator) return Cursor is - F : constant Count_Type := Object.Container.Last; begin - if F = 0 then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Maps.Last (Object.Container.all); else - return Cursor'(Object.Container.all'Unchecked_Access, F); + return Cursor'(Object.Container, Object.Node); end if; end Last; @@ -1044,8 +1142,16 @@ package body Ada.Containers.Bounded_Ordered_Maps is (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + return Next (Position); end Next; @@ -1095,8 +1201,16 @@ package body Ada.Containers.Bounded_Ordered_Maps is (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong map"; + end if; + return Previous (Position); end Previous; diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads index e1f9f08f379..05c55730f10 100644 --- a/gcc/ada/a-cborma.ads +++ b/gcc/ada/a-cborma.ads @@ -227,17 +227,18 @@ package Ada.Containers.Bounded_Ordered_Maps is (Container : Map; Process : not null access procedure (Position : Cursor)); + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class; + (Container : Map) + return Map_Iterator_Interfaces.Reversible_Iterator'Class; function Iterate (Container : Map; Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'class; - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); + return Map_Iterator_Interfaces.Reversible_Iterator'Class; private diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb index 674d2abee33..17fa7950237 100644 --- a/gcc/ada/a-cborse.adb +++ b/gcc/ada/a-cborse.adb @@ -38,19 +38,22 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Ordered_Sets is - type Iterator is new - Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record - Container : access constant Set; - Node : Count_Type; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Count_Type; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -568,6 +571,22 @@ package body Ada.Containers.Bounded_Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -591,9 +610,24 @@ package body Ada.Containers.Bounded_Ordered_Sets is function First (Object : Iterator) return Cursor is begin - return (if Object.Container.First = 0 then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.First)); + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Sets.First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; end First; ------------------- @@ -1206,22 +1240,76 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Iterate; function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - if Container.Length = 0 then - return Iterator'(null, 0); - else - return Iterator'(Container'Unchecked_Access, Container.First); - end if; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is 0 (as is the case here), this means the iterator object + -- was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is positive (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. (Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration.) + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -1236,9 +1324,24 @@ package body Ada.Containers.Bounded_Ordered_Sets is function Last (Object : Iterator) return Cursor is begin - return (if Object.Container.Last = 0 then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Last)); + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Sets.Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; end Last; ------------------ @@ -1323,8 +1426,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + return Next (Position); end Next; @@ -1374,8 +1485,16 @@ package body Ada.Containers.Bounded_Ordered_Sets is end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + return Previous (Position); end Previous; diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads index 0c8ae6b1703..9c4fdb4f31d 100644 --- a/gcc/ada/a-cborse.ads +++ b/gcc/ada/a-cborse.ads @@ -31,9 +31,9 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with Ada.Iterator_Interfaces; private with Ada.Containers.Red_Black_Trees; with Ada.Streams; use Ada.Streams; +with Ada.Iterator_Interfaces; generic type Element_Type is private; @@ -62,7 +62,7 @@ package Ada.Containers.Bounded_Ordered_Sets is No_Element : constant Cursor; function Has_Element (Position : Cursor) return Boolean; - package Ordered_Set_Iterator_Interfaces is new + package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); type Constant_Reference_Type @@ -212,12 +212,12 @@ package Ada.Containers.Bounded_Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; generic type Key_Type (<>) is private; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 8b513222ef8..12242583ebe 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -27,17 +27,20 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; - with Ada.Unchecked_Deallocation; +with System; use type System.Address; package body Ada.Containers.Doubly_Linked_Lists is - type Iterator is new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Node_Access; + + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -395,6 +398,22 @@ package body Ada.Containers.Doubly_Linked_Lists is return Position.Node.Element; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -421,7 +440,7 @@ package body Ada.Containers.Doubly_Linked_Lists is while Node /= null loop if Node.Element = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; @@ -440,15 +459,28 @@ package body Ada.Containers.Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.First); + return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is begin - if Object.Container = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Doubly_Linked_Lists.First (Object.Container.all); else - return (Object.Container, Object.Container.First); + return Cursor'(Object.Container, Object.Node); end if; end First; @@ -843,9 +875,7 @@ package body Ada.Containers.Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Node_Access := Container.First; begin @@ -853,7 +883,7 @@ package body Ada.Containers.Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Next; end loop; exception @@ -866,22 +896,75 @@ package body Ada.Containers.Doubly_Linked_Lists is end Iterate; function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'class + return List_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - if Container.Length = 0 then - return Iterator'(null, null); - else - return Iterator'(Container'Unchecked_Access, Container.First); - end if; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : List; Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'class + return List_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong list"; + end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -894,15 +977,28 @@ package body Ada.Containers.Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Last); + return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is begin - if Object.Container = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Doubly_Linked_Lists.Last (Object.Container.all); else - return (Object.Container, Object.Container.Last); + return Cursor'(Object.Container, Object.Node); end if; end Last; @@ -992,11 +1088,16 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) return Cursor is begin - if Position.Node = Object.Container.Last then + if Position.Container = null then return No_Element; - else - return (Object.Container, Position.Node.Next); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong list"; + end if; + + return Next (Position); end Next; ------------- @@ -1046,11 +1147,16 @@ package body Ada.Containers.Doubly_Linked_Lists is Position : Cursor) return Cursor is begin - if Position.Node = Position.Container.First then + if Position.Container = null then return No_Element; - else - return (Object.Container, Position.Node.Prev); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong list"; + end if; + + return Previous (Position); end Previous; ------------------- @@ -1338,7 +1444,7 @@ package body Ada.Containers.Doubly_Linked_Lists is while Node /= null loop if Node.Element = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; @@ -1365,7 +1471,7 @@ package body Ada.Containers.Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Prev; end loop; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 2de03e520aa..0e6437602f5 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -306,7 +306,7 @@ private for List'Write use Write; - type List_Access is access constant List; + type List_Access is access all List; for List_Access'Storage_Size use 0; type Cursor is diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index 93a88a725d6..3c73c0467aa 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.adb @@ -743,7 +743,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is begin if Before.Node /= 0 then - null; pragma Assert (Vet (Container, Before), "bad cursor in Insert"); end if; @@ -793,7 +792,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is begin if Before.Node /= 0 then - null; pragma Assert (Vet (Container, Before), "bad cursor in Insert"); end if; @@ -1007,16 +1005,62 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is Clear (Target); - while Source.Length > 0 loop + while Source.Length > 1 loop + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last /= Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy first element from Source to Target + X := Source.First; Append (Target, N (X).Element); -- optimize away??? + -- Unlink first node of Source + Source.First := N (X).Next; N (Source.First).Prev := 0; Source.Length := Source.Length - 1; + + -- The representation invariants for Source have been restored. It is + -- now safe to free the unlinked node, without fear of corrupting the + -- active links of Source. + + -- Note that the algorithm we use here models similar algorithms used + -- in the unbounded form of the doubly-linked list container. In that + -- case, Free is an instantation of Unchecked_Deallocation, which can + -- fail (because PE will be raised if controlled Finalize fails), so + -- we must defer the call until the last step. Here in the bounded + -- form, Free merely links the node we have just "deallocated" onto a + -- list of inactive nodes, so technically Free cannot fail. However, + -- for consistency, we handle Free the same way here as we do for the + -- unbounded form, with the pessimistic assumption that it can fail. + Free (Source, X); end loop; + + if Source.Length = 1 then + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last = Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy element from Source to Target + + X := Source.First; + Append (Target, N (X).Element); + + -- Unlink node of Source + + Source.First := 0; + Source.Last := 0; + Source.Length := 0; + + -- Return the unlinked node to the free store + + Free (Source, X); + end if; end Move; ---------- @@ -1172,8 +1216,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is "attempt to tamper with cursors (list is locked)"; end if; - pragma Assert (Vet (Container, Position), - "bad cursor in Replace_Element"); + pragma Assert + (Vet (Container, Position), "bad cursor in Replace_Element"); declare N : Node_Array renames Container.Nodes; @@ -1372,7 +1416,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is begin if Before.Node /= 0 then - null; pragma Assert (Vet (Target, Before), "bad cursor in Splice"); end if; @@ -1464,17 +1507,16 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is begin if Before.Node /= 0 then - null; - pragma Assert (Vet (Container, Before), - "bad Before cursor in Splice"); + pragma Assert + (Vet (Container, Before), "bad Before cursor in Splice"); end if; if Position.Node = 0 then raise Constraint_Error with "Position cursor has no element"; end if; - pragma Assert (Vet (Container, Position), - "bad Position cursor in Splice"); + pragma Assert + (Vet (Container, Position), "bad Position cursor in Splice"); if Position.Node = Before.Node or else N (Position.Node).Next = Before.Node @@ -1683,8 +1725,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is raise Constraint_Error with "Position cursor has no element"; end if; - pragma Assert (Vet (Container, Position), - "bad cursor in Update_Element"); + pragma Assert + (Vet (Container, Position), "bad cursor in Update_Element"); declare B : Natural renames Container.Busy; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb index dbdc6de47d4..b74e8e115e4 100644 --- a/gcc/ada/a-cidlli.adb +++ b/gcc/ada/a-cidlli.adb @@ -27,23 +27,25 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with System; use type System.Address; with Ada.Unchecked_Deallocation; +with System; use type System.Address; package body Ada.Containers.Indefinite_Doubly_Linked_Lists is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new - List_Iterator_Interfaces.Reversible_Iterator with record - Container : List_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -429,6 +431,22 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return Position.Node.Element.all; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -459,7 +477,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is while Node /= null loop if Node.Element.all = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Next; @@ -478,15 +496,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.First); + return Cursor'(Container'Unrestricted_Access, Container.First); end First; function First (Object : Iterator) return Cursor is begin - if Object.Container = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Indefinite_Doubly_Linked_Lists.First (Object.Container.all); else - return Cursor'(Object.Container, Object.Container.First); + return Cursor'(Object.Container, Object.Node); end if; end First; @@ -871,9 +902,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List; Process : not null access procedure (Position : Cursor)) is - C : List renames Container'Unrestricted_Access.all; - B : Natural renames C.Busy; - + B : Natural renames Container'Unrestricted_Access.all.Busy; Node : Node_Access := Container.First; begin @@ -881,7 +910,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Next; end loop; exception @@ -897,22 +926,75 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is (Container : List) return List_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - if Container.Length = 0 then - return Iterator'(null, null); - else - return Iterator'(Container'Unchecked_Access, Container.First); - end if; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : List; Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'class + return List_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong list"; + end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -925,15 +1007,28 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Container.Last); + return Cursor'(Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is begin - if Object.Container = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all); else - return Cursor'(Object.Container, Object.Container.Last); + return Cursor'(Object.Container, Object.Node); end if; end Last; @@ -1016,12 +1111,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Next (Object : Iterator; Position : Cursor) return Cursor is begin - if Position.Node = Object.Container.Last then + if Position.Container = null then return No_Element; + end if; - else - return (Object.Container, Position.Node.Next); + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong list"; end if; + + return Next (Position); end Next; ------------- @@ -1067,11 +1166,16 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is function Previous (Object : Iterator; Position : Cursor) return Cursor is begin - if Position.Node = Position.Container.First then + if Position.Container = null then return No_Element; - else - return (Object.Container, Position.Node.Prev); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong list"; + end if; + + return Previous (Position); end Previous; ------------------- @@ -1380,7 +1484,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is while Node /= null loop if Node.Element.all = Item then - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end if; Node := Node.Prev; @@ -1407,7 +1511,7 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is begin while Node /= null loop - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); Node := Node.Prev; end loop; exception diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads index c40ad30b155..be1b4344a8a 100644 --- a/gcc/ada/a-cidlli.ads +++ b/gcc/ada/a-cidlli.ads @@ -309,7 +309,7 @@ private for List'Write use Write; - type List_Access is access constant List; + type List_Access is access all List; for List_Access'Storage_Size use 0; type Cursor is diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index b90c5426481..e9b9cc05d91 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -34,7 +34,6 @@ with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Maps is @@ -45,11 +44,13 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Free_Element is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; @@ -422,6 +423,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -434,7 +447,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; -------------------- @@ -472,18 +485,12 @@ package body Ada.Containers.Indefinite_Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end First; function First (Object : Iterator) return Cursor is - M : constant Map_Access := Object.Container; - N : constant Node_Access := HT_Ops.First (M.HT); begin - if N = null then - return No_Element; - else - return Cursor'(Object.Container.all'Unchecked_Access, N); - end if; + return Object.Container.First; end First; ---------- @@ -694,10 +701,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing Iterate @@ -715,13 +722,18 @@ package body Ada.Containers.Indefinite_Hashed_Maps is B := B - 1; end Iterate; - function Iterate (Container : Map) - return Map_Iterator_Interfaces.Forward_Iterator'class + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - Node : constant Node_Access := HT_Ops.First (Container.HT); - It : constant Iterator := (Container'Unrestricted_Access, Node); + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- @@ -809,11 +821,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is function Next (Object : Iterator; Position : Cursor) return Cursor is begin - if Position.Node = null then + if Position.Container = null then return No_Element; - else - return (Object.Container, Next (Position).Node); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); end Next; ------------------- diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads index 7c67c315583..3b639f4cff7 100644 --- a/gcc/ada/a-cihama.ads +++ b/gcc/ada/a-cihama.ads @@ -341,11 +341,10 @@ private use HT_Types; use Ada.Finalization; - overriding procedure Adjust (Container : in out Map); - + overriding procedure Adjust (Container : in out Map); overriding procedure Finalize (Container : in out Map); - type Map_Access is access constant Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index e29a204570e..3a93f91f5c2 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -36,16 +36,18 @@ with Ada.Containers.Hash_Tables.Generic_Keys; pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); with Ada.Containers.Prime_Numbers; - -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Hashed_Sets is - type Iterator is new Set_Iterator_Interfaces.Forward_Iterator with record + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record Container : Set_Access; - Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next @@ -569,6 +571,18 @@ package body Ada.Containers.Indefinite_Hashed_Sets is HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -649,10 +663,8 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end First; function First (Object : Iterator) return Cursor is - Node : constant Node_Access := HT_Ops.First (Object.Container.HT); begin - return (if Node = null then No_Element - else Cursor'(Object.Container, Node)); + return Object.Container.First; end First; ---------- @@ -990,7 +1002,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing for Iterate @@ -1009,9 +1021,17 @@ package body Ada.Containers.Indefinite_Hashed_Sets is end Iterate; function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class is + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return Iterator'(Container'Unrestricted_Access, First (Container)); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; ------------ @@ -1072,12 +1092,16 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Position : Cursor) return Cursor is begin + if Position.Container = null then + return No_Element; + end if; + if Position.Container /= Object.Container then raise Program_Error with - "Position cursor designates wrong set"; + "Position cursor of Next designates wrong set"; end if; - return (if Position.Node = null then No_Element else Next (Position)); + return Next (Position); end Next; ------------- @@ -1895,7 +1919,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); if X = null then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; Free (X); @@ -1913,7 +1937,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is begin if Node = null then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Node.Element.all; diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index 2fdc8a75469..9e211ad156a 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -28,35 +28,41 @@ ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Multiway_Trees is - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next - (Object : Iterator; + (Object : Iterator; Position : Cursor) return Cursor; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next - (Object : Child_Iterator; + (Object : Child_Iterator; Position : Cursor) return Cursor; overriding function Previous - (Object : Child_Iterator; + (Object : Child_Iterator; Position : Cursor) return Cursor; overriding function Last (Object : Child_Iterator) return Cursor; @@ -925,6 +931,34 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return Equal_Children (Left_Subtree, Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1304,8 +1338,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1326,13 +1359,19 @@ package body Ada.Containers.Indefinite_Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1349,7 +1388,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -1396,9 +1435,16 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1409,8 +1455,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1423,7 +1478,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; declare - B : Integer renames Position.Container.Busy; + B : Natural renames Position.Container.Busy; begin B := B + 1; @@ -1789,8 +1844,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2052,7 +2107,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -2555,8 +2610,8 @@ package body Ada.Containers.Indefinite_Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads index 29be8ca39ea..6d5684d1b35 100644 --- a/gcc/ada/a-cimutr.ads +++ b/gcc/ada/a-cimutr.ads @@ -327,8 +327,8 @@ private type Tree is new Controlled with record Root : aliased Tree_Node_Type; - Busy : Integer := 0; - Lock : Integer := 0; + Busy : Natural := 0; + Lock : Natural := 0; Count : Count_Type := 0; end record; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb index cd95b9fd5ab..3aa3c17e1c1 100644 --- a/gcc/ada/a-ciorma.adb +++ b/gcc/ada/a-ciorma.adb @@ -40,15 +40,17 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Maps is pragma Suppress (All_Checks); - type Iterator is new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -535,6 +537,22 @@ package body Ada.Containers.Indefinite_Ordered_Maps is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -558,11 +576,25 @@ package body Ada.Containers.Indefinite_Ordered_Maps is end First; function First (Object : Iterator) return Cursor is - M : constant Map_Access := Object.Container; - N : constant Node_Access := M.Tree.First; begin - return (if N = null then No_Element - else Cursor'(Object.Container.all'Unchecked_Access, N)); + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; end First; ------------------- @@ -571,13 +603,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function First_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; - begin if T.First = null then raise Constraint_Error with "map is empty"; + else + return T.First.Element.all; end if; - - return T.First.Element.all; end First_Element; --------------- @@ -586,13 +617,12 @@ package body Ada.Containers.Indefinite_Ordered_Maps is function First_Key (Container : Map) return Key_Type is T : Tree_Type renames Container.Tree; - begin if T.First = null then raise Constraint_Error with "map is empty"; + else + return T.First.Key.all; end if; - - return T.First.Key.all; end First_Key; ----------- @@ -845,7 +875,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; -- Start of processing for Iterate @@ -864,22 +894,78 @@ package body Ada.Containers.Indefinite_Ordered_Maps is end Iterate; function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class + (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - Node : constant Node_Access := Container.Tree.First; - It : constant Iterator := (Container'Unrestricted_Access, Node); + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin - return It; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Map; Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'class + return Map_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unrestricted_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- @@ -916,11 +1002,25 @@ package body Ada.Containers.Indefinite_Ordered_Maps is end Last; function Last (Object : Iterator) return Cursor is - M : constant Map_Access := Object.Container; - N : constant Node_Access := M.Tree.Last; begin - return (if N = null then No_Element - else Cursor'(Object.Container.all'Unchecked_Access, N)); + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; end Last; ------------------ @@ -1017,8 +1117,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : Cursor) return Cursor is begin - return (if Position.Node = null then No_Element - else (Object.Container, Tree_Operations.Next (Position.Node))); + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); end Next; ------------ @@ -1065,9 +1173,16 @@ package body Ada.Containers.Indefinite_Ordered_Maps is Position : Cursor) return Cursor is begin - return - (if Position.Node = null then No_Element - else (Object.Container, Tree_Operations.Previous (Position.Node))); + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong map"; + end if; + + return Previous (Position); end Previous; ------------------- @@ -1490,4 +1605,5 @@ package body Ada.Containers.Indefinite_Ordered_Maps is begin raise Program_Error with "attempt to stream reference"; end Write; + end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads index 1c19b81161f..f4c1321835e 100644 --- a/gcc/ada/a-ciorma.ads +++ b/gcc/ada/a-ciorma.ads @@ -201,14 +201,18 @@ package Ada.Containers.Indefinite_Ordered_Maps is (Container : Map; Process : not null access procedure (Position : Cursor)); + -- The map container supports iteration in both the forward and reverse + -- directions, hence these constructor functions return an object that + -- supports the Reversible_Iterator interface. + function Iterate (Container : Map) - return Map_Iterator_Interfaces.Forward_Iterator'class; + return Map_Iterator_Interfaces.Reversible_Iterator'Class; function Iterate (Container : Map; Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'class; + return Map_Iterator_Interfaces.Reversible_Iterator'Class; private diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb index 56c33cfe670..4d0f3dcbd6a 100644 --- a/gcc/ada/a-ciorse.adb +++ b/gcc/ada/a-ciorse.adb @@ -37,20 +37,21 @@ with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Indefinite_Ordered_Sets is - type Iterator is new - Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record - Container : access constant Set; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -571,6 +572,22 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -600,8 +617,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function First (Object : Iterator) return Cursor is begin - return Cursor'( - Object.Container.all'Unrestricted_Access, Object.Container.Tree.First); + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; end First; ------------------- @@ -1238,7 +1271,7 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; B : Natural renames T.Busy; -- Start of processing for Iterate @@ -1259,22 +1292,78 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := - (Container'Unchecked_Access, Container.Tree.First); + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin - return It; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; ---------- @@ -1290,9 +1379,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is function Last (Object : Iterator) return Cursor is begin - return (if Object.Container.Tree.Last = null then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Tree.Last)); + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; end Last; ------------------ @@ -1372,8 +1476,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + return Next (Position); end Next; @@ -1430,8 +1542,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + return Previous (Position); end Previous; diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads index c0ead018bb2..ac711246542 100644 --- a/gcc/ada/a-ciorse.ads +++ b/gcc/ada/a-ciorse.ads @@ -64,7 +64,7 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Has_Element (Position : Cursor) return Boolean; - package Ordered_Set_Iterator_Interfaces is new + package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); type Constant_Reference_Type @@ -233,12 +233,12 @@ package Ada.Containers.Indefinite_Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; generic type Key_Type (<>) is private; diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb index e78e3ce12d3..e570f828bb1 100644 --- a/gcc/ada/a-cobove.adb +++ b/gcc/ada/a-cobove.adb @@ -28,16 +28,19 @@ ------------------------------------------------------------------------------ with Ada.Containers.Generic_Array_Sort; - +with Ada.Finalization; use Ada.Finalization; with System; use type System.Address; package body Ada.Containers.Bounded_Vectors is - type Iterator is new - Vector_Iterator_Interfaces.Reversible_Iterator with record - Container : Vector_Access; - Index : Index_Type; - end record; + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; @@ -658,6 +661,22 @@ package body Ada.Containers.Bounded_Vectors is end if; end Element; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1607,8 +1626,7 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1630,8 +1648,16 @@ package body Ada.Containers.Bounded_Vectors is (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container'Unrestricted_Access, Index_Type'First); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -1639,8 +1665,16 @@ package body Ada.Containers.Bounded_Vectors is Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Container'Unrestricted_Access, Start.Index); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 351030d3a7b..8c92a303076 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -39,11 +39,13 @@ with System; use type System.Address; package body Ada.Containers.Hashed_Maps is - type Iterator is new - Map_Iterator_Interfaces.Forward_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record; + + overriding procedure Finalize (Object : in out Iterator); overriding function First (Object : Iterator) return Cursor; @@ -386,6 +388,18 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Finalize (Container.HT); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.HT.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -398,7 +412,7 @@ package body Ada.Containers.Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end Find; -------------------- @@ -436,18 +450,12 @@ package body Ada.Containers.Hashed_Maps is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Node); + return Cursor'(Container'Unrestricted_Access, Node); end First; function First (Object : Iterator) return Cursor is - M : constant Map_Access := Object.Container; - N : constant Node_Access := HT_Ops.First (M.HT); begin - if N = null then - return No_Element; - end if; - - return Cursor'(Object.Container.all'Unchecked_Access, N); + return Object.Container.First; end First; ---------- @@ -553,7 +561,7 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -595,7 +603,7 @@ package body Ada.Containers.Hashed_Maps is HT_Ops.Reserve_Capacity (HT, HT.Length); end if; - Position.Container := Container'Unchecked_Access; + Position.Container := Container'Unrestricted_Access; end Insert; procedure Insert @@ -645,10 +653,10 @@ package body Ada.Containers.Hashed_Maps is procedure Process_Node (Node : Node_Access) is begin - Process (Cursor'(Container'Unchecked_Access, Node)); + Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - B : Natural renames Container'Unrestricted_Access.HT.Busy; + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; -- Start of processing for Iterate @@ -667,12 +675,17 @@ package body Ada.Containers.Hashed_Maps is end Iterate; function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class is - Node : constant Node_Access := HT_Ops.First (Container.HT); - It : constant Iterator := (Container'Unrestricted_Access, Node); + B : Natural renames Container'Unrestricted_Access.all.HT.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + B := B + 1; + end return; end Iterate; --------- @@ -752,11 +765,16 @@ package body Ada.Containers.Hashed_Maps is Position : Cursor) return Cursor is begin - if Position.Node = null then + if Position.Container = null then return No_Element; - else - return (Object.Container, Next (Position).Node); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); end Next; ------------------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 5f01994e8ad..93c3504e8d5 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -384,7 +384,7 @@ private for Map'Read use Read; - type Map_Access is access constant Map; + type Map_Access is access all Map; for Map_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index e0b2345234b..fadff195ff5 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -41,6 +41,17 @@ with System; use type System.Address; package body Ada.Containers.Hashed_Sets is + type Iterator is limited new + Set_Iterator_Interfaces.Forward_Iterator with record + Container : Set_Access; + end record; + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -601,6 +612,11 @@ package body Ada.Containers.Hashed_Sets is return Cursor'(Container'Unrestricted_Access, Node); end First; + function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + ---------- -- Free -- ---------- @@ -920,6 +936,13 @@ package body Ada.Containers.Hashed_Sets is B := B - 1; end Iterate; + function Iterate + (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return Iterator'(Container => Container'Unrestricted_Access); + end Iterate; + ------------ -- Length -- ------------ @@ -973,6 +996,23 @@ package body Ada.Containers.Hashed_Sets is Position := Next (Position); end Next; + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + ------------- -- Overlap -- ------------- @@ -1695,7 +1735,7 @@ package body Ada.Containers.Hashed_Sets is begin if Node = null then - raise Constraint_Error with "key not in map"; + raise Constraint_Error with "key not in map"; -- ??? "set" end if; return Node.Element; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index 0bb370bfe83..96944cd2b2f 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -34,6 +34,7 @@ private with Ada.Containers.Hash_Tables; private with Ada.Streams; private with Ada.Finalization; +with Ada.Iterator_Interfaces; generic type Element_Type is private; @@ -49,7 +50,11 @@ package Ada.Containers.Hashed_Sets is pragma Preelaborate; pragma Remote_Types; - type Set is tagged private; + type Set is tagged private + with + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Set); type Cursor is private; @@ -63,6 +68,12 @@ package Ada.Containers.Hashed_Sets is -- Cursor objects declared without an initialization expression are -- initialized to the value No_Element. + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + function "=" (Left, Right : Set) return Boolean; -- For each element in Left, set equality attempts to find the equal -- element in Right; if a search fails, then set equality immediately @@ -303,9 +314,6 @@ package Ada.Containers.Hashed_Sets is function Contains (Container : Set; Item : Element_Type) return Boolean; -- Equivalent to Find (Container, Item) /= No_Element - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - function Equivalent_Elements (Left, Right : Cursor) return Boolean; -- Returns the result of calling Equivalent_Elements with the elements of -- the nodes designated by cursors Left and Right. @@ -327,6 +335,9 @@ package Ada.Containers.Hashed_Sets is Process : not null access procedure (Position : Cursor)); -- Calls Process for each node in the set + function Iterate + (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class; + generic type Key_Type (<>) is private; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb index e35f2f781de..02a3c53e3f2 100644 --- a/gcc/ada/a-coinve.adb +++ b/gcc/ada/a-coinve.adb @@ -29,7 +29,7 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Indefinite_Vectors is @@ -39,15 +39,17 @@ package body Ada.Containers.Indefinite_Vectors is procedure Free is new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - type Iterator is new - Vector_Iterator_Interfaces.Reversible_Iterator with record + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record Container : Vector_Access; Index : Index_Type; end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -1105,6 +1107,18 @@ package body Ada.Containers.Indefinite_Vectors is end; end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1129,7 +1143,7 @@ package body Ada.Containers.Indefinite_Vectors is if Container.Elements.EA (J) /= null and then Container.Elements.EA (J).all = Item then - return (Container'Unchecked_Access, J); + return (Container'Unrestricted_Access, J); end if; end loop; @@ -1167,7 +1181,7 @@ package body Ada.Containers.Indefinite_Vectors is return No_Element; end if; - return (Container'Unchecked_Access, Index_Type'First); + return (Container'Unrestricted_Access, Index_Type'First); end First; function First (Object : Iterator) return Cursor is @@ -1982,7 +1996,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2018,7 +2032,8 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + and then Before.Container /= + Vector_Access'(Container'Unrestricted_Access) then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2029,7 +2044,7 @@ package body Ada.Containers.Indefinite_Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2051,7 +2066,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert (Container, Index, New_Item); - Position := Cursor'(Container'Unchecked_Access, Index); + Position := Cursor'(Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2064,7 +2079,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2101,7 +2116,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2112,7 +2127,7 @@ package body Ada.Containers.Indefinite_Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2134,7 +2149,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert (Container, Index, New_Item, Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; ------------------ @@ -2465,7 +2480,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2476,7 +2491,7 @@ package body Ada.Containers.Indefinite_Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2498,7 +2513,7 @@ package body Ada.Containers.Indefinite_Vectors is Insert_Space (Container, Index, Count); - Position := Cursor'(Container'Unchecked_Access, Index); + Position := Cursor'(Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2518,15 +2533,14 @@ package body Ada.Containers.Indefinite_Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; begin for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -2540,9 +2554,16 @@ package body Ada.Containers.Indefinite_Vectors is function Iterate (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Index_Type'First); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -2550,10 +2571,16 @@ package body Ada.Containers.Indefinite_Vectors is Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := - (Container'Unchecked_Access, Start.Index); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- @@ -2566,7 +2593,7 @@ package body Ada.Containers.Indefinite_Vectors is return No_Element; end if; - return (Container'Unchecked_Access, Container.Last); + return (Container'Unrestricted_Access, Container.Last); end Last; function Last (Object : Iterator) return Cursor is @@ -3313,7 +3340,7 @@ package body Ada.Containers.Indefinite_Vectors is begin if Position.Container /= null - and then Position.Container /= Container'Unchecked_Access + and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -3330,7 +3357,7 @@ package body Ada.Containers.Indefinite_Vectors is if Container.Elements.EA (Indx) /= null and then Container.Elements.EA (Indx).all = Item then - return (Container'Unchecked_Access, Indx); + return (Container'Unrestricted_Access, Indx); end if; end loop; @@ -3376,7 +3403,7 @@ package body Ada.Containers.Indefinite_Vectors is begin for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -3491,7 +3518,7 @@ package body Ada.Containers.Indefinite_Vectors is return No_Element; end if; - return Cursor'(Container'Unchecked_Access, Index); + return Cursor'(Container'Unrestricted_Access, Index); end To_Cursor; -------------- diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads index 06568278997..85d68ebf7ee 100644 --- a/gcc/ada/a-coinve.ads +++ b/gcc/ada/a-coinve.ads @@ -426,7 +426,7 @@ private for Vector'Read use Read; - type Vector_Access is access constant Vector; + type Vector_Access is access all Vector; for Vector_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index 86be79ffc35..e78aaccf957 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -29,28 +29,34 @@ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Multiway_Trees is - type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + type Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with record Container : Tree_Access; Position : Cursor; From_Root : Boolean; end record; - type Child_Iterator is new Tree_Iterator_Interfaces.Reversible_Iterator with + type Child_Iterator is new Limited_Controlled and + Tree_Iterator_Interfaces.Reversible_Iterator with record Container : Tree_Access; Position : Cursor; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; Position : Cursor) return Cursor; + overriding procedure Finalize (Object : in out Child_Iterator); + overriding function First (Object : Child_Iterator) return Cursor; overriding function Next (Object : Child_Iterator; @@ -898,6 +904,34 @@ package body Ada.Containers.Multiway_Trees is return Equal_Children (Left_Subtree, Right_Subtree); end Equal_Subtree; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + + procedure Finalize (Object : in out Child_Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1342,8 +1376,7 @@ package body Ada.Containers.Multiway_Trees is (Container : Tree; Process : not null access procedure (Position : Cursor)) is - T : Tree renames Container'Unrestricted_Access.all; - B : Integer renames T.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; @@ -1364,13 +1397,19 @@ package body Ada.Containers.Multiway_Trees is function Iterate (Container : Tree) return Tree_Iterator_Interfaces.Forward_Iterator'Class is - Root_Cursor : constant Cursor := - (Container'Unrestricted_Access, Root_Node (Container)); + B : Natural renames Container'Unrestricted_Access.all.Busy; + RC : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin - return - Iterator'(Container'Unrestricted_Access, - First_Child (Root_Cursor), - From_Root => True); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Position => First_Child (RC), + From_Root => True) + do + B := B + 1; + end return; end Iterate; ---------------------- @@ -1387,7 +1426,7 @@ package body Ada.Containers.Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -1434,9 +1473,16 @@ package body Ada.Containers.Multiway_Trees is Parent : Cursor) return Tree_Iterator_Interfaces.Reversible_Iterator'Class is - pragma Unreferenced (Container); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return Child_Iterator'(Parent.Container, Parent); + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => Parent.Container, + Position => Parent) + do + B := B + 1; + end return; end Iterate_Children; --------------------- @@ -1447,8 +1493,17 @@ package body Ada.Containers.Multiway_Trees is (Position : Cursor) return Tree_Iterator_Interfaces.Forward_Iterator'Class is + B : Natural renames Position.Container'Unrestricted_Access.all.Busy; + begin - return Iterator'(Position.Container, Position, From_Root => False); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Position.Container, + Position => Position, + From_Root => False) + do + B := B + 1; + end return; end Iterate_Subtree; procedure Iterate_Subtree @@ -1461,7 +1516,7 @@ package body Ada.Containers.Multiway_Trees is end if; declare - B : Integer renames Position.Container.Busy; + B : Natural renames Position.Container.Busy; begin B := B + 1; @@ -1807,8 +1862,8 @@ package body Ada.Containers.Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; @@ -2060,7 +2115,7 @@ package body Ada.Containers.Multiway_Trees is end if; declare - B : Integer renames Parent.Container.Busy; + B : Natural renames Parent.Container.Busy; C : Tree_Node_Access; begin @@ -2578,8 +2633,8 @@ package body Ada.Containers.Multiway_Trees is declare T : Tree renames Position.Container.all'Unrestricted_Access.all; - B : Integer renames T.Busy; - L : Integer renames T.Lock; + B : Natural renames T.Busy; + L : Natural renames T.Lock; begin B := B + 1; diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index b035e1637fe..37e2eda0c2c 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -372,8 +372,8 @@ private type Tree is new Controlled with record Root : aliased Root_Node_Type; - Busy : Integer := 0; - Lock : Integer := 0; + Busy : Natural := 0; + Lock : Natural := 0; Count : Count_Type := 0; end record; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 79071810182..a94f11c9f93 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -29,7 +29,6 @@ with Ada.Containers.Generic_Array_Sort; with Ada.Unchecked_Deallocation; - with System; use type System.Address; package body Ada.Containers.Vectors is @@ -37,12 +36,15 @@ package body Ada.Containers.Vectors is procedure Free is new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - type Iterator is new Vector_Iterator_Interfaces.Reversible_Iterator with + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with record Container : Vector_Access; Index : Index_Type; end record; + overriding procedure Finalize (Object : in out Iterator); + overriding function First (Object : Iterator) return Cursor; overriding function Last (Object : Iterator) return Cursor; overriding function Next @@ -778,6 +780,18 @@ package body Ada.Containers.Vectors is Free (X); end Finalize; + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -800,7 +814,7 @@ package body Ada.Containers.Vectors is for J in Position.Index .. Container.Last loop if Container.Elements.EA (J) = Item then - return (Container'Unchecked_Access, J); + return (Container'Unrestricted_Access, J); end if; end loop; @@ -835,7 +849,7 @@ package body Ada.Containers.Vectors is if Is_Empty (Container) then return No_Element; else - return (Container'Unchecked_Access, Index_Type'First); + return (Container'Unrestricted_Access, Index_Type'First); end if; end First; @@ -1500,7 +1514,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1536,7 +1550,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1547,7 +1561,7 @@ package body Ada.Containers.Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -1569,7 +1583,7 @@ package body Ada.Containers.Vectors is Insert (Container, Index, New_Item); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -1582,7 +1596,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1619,7 +1633,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -1630,7 +1644,7 @@ package body Ada.Containers.Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -1652,7 +1666,7 @@ package body Ada.Containers.Vectors is Insert (Container, Index, New_Item, Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert; procedure Insert @@ -2036,7 +2050,7 @@ package body Ada.Containers.Vectors is begin if Before.Container /= null - and then Before.Container /= Container'Unchecked_Access + and then Before.Container /= Container'Unrestricted_Access then raise Program_Error with "Before cursor denotes wrong container"; end if; @@ -2047,7 +2061,7 @@ package body Ada.Containers.Vectors is then Position := No_Element; else - Position := (Container'Unchecked_Access, Before.Index); + Position := (Container'Unrestricted_Access, Before.Index); end if; return; @@ -2069,7 +2083,7 @@ package body Ada.Containers.Vectors is Insert_Space (Container, Index, Count => Count); - Position := (Container'Unchecked_Access, Index); + Position := (Container'Unrestricted_Access, Index); end Insert_Space; -------------- @@ -2089,15 +2103,14 @@ package body Ada.Containers.Vectors is (Container : Vector; Process : not null access procedure (Position : Cursor)) is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; + B : Natural renames Container'Unrestricted_Access.all.Busy; begin B := B + 1; begin for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -2112,9 +2125,16 @@ package body Ada.Containers.Vectors is (Container : Vector) return Vector_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Index_Type'First); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Index_Type'First) + do + B := B + 1; + end return; end Iterate; function Iterate @@ -2122,9 +2142,16 @@ package body Ada.Containers.Vectors is Start : Cursor) return Vector_Iterator_Interfaces.Reversible_Iterator'class is - It : constant Iterator := (Container'Unchecked_Access, Start.Index); + B : Natural renames Container'Unrestricted_Access.all.Busy; + begin - return It; + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Index => Start.Index) + do + B := B + 1; + end return; end Iterate; ---------- @@ -2136,7 +2163,7 @@ package body Ada.Containers.Vectors is if Is_Empty (Container) then return No_Element; else - return (Container'Unchecked_Access, Container.Last); + return (Container'Unrestricted_Access, Container.Last); end if; end Last; @@ -2903,7 +2930,7 @@ package body Ada.Containers.Vectors is begin if Position.Container /= null - and then Position.Container /= Container'Unchecked_Access + and then Position.Container /= Container'Unrestricted_Access then raise Program_Error with "Position cursor denotes wrong container"; end if; @@ -2915,7 +2942,7 @@ package body Ada.Containers.Vectors is for Indx in reverse Index_Type'First .. Last loop if Container.Elements.EA (Indx) = Item then - return (Container'Unchecked_Access, Indx); + return (Container'Unrestricted_Access, Indx); end if; end loop; @@ -2960,7 +2987,7 @@ package body Ada.Containers.Vectors is begin for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unchecked_Access, Indx)); + Process (Cursor'(Container'Unrestricted_Access, Indx)); end loop; exception when others => @@ -3061,7 +3088,7 @@ package body Ada.Containers.Vectors is if Index not in Index_Type'First .. Container.Last then return No_Element; else - return (Container'Unchecked_Access, Index); + return (Container'Unrestricted_Access, Index); end if; end To_Cursor; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 9eb82c791fe..00f9b2abbac 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -410,7 +410,7 @@ private Lock : Natural := 0; end record; - type Vector_Access is access constant Vector; + type Vector_Access is access all Vector; for Vector_Access'Storage_Size use 0; type Cursor is record diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index e8099c3c297..778d223e291 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -39,15 +39,17 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Maps is - type Iterator is new - Map_Iterator_Interfaces.Reversible_Iterator with record - Container : Map_Access; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -488,6 +490,22 @@ package body Ada.Containers.Ordered_Maps is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -518,13 +536,24 @@ package body Ada.Containers.Ordered_Maps is end First; function First (Object : Iterator) return Cursor is - M : constant Map_Access := Object.Container; - N : constant Node_Access := M.Tree.First; begin - if N = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; else - return Cursor'(Object.Container.all'Unchecked_Access, N); + return Cursor'(Object.Container, Object.Node); end if; end First; @@ -534,7 +563,6 @@ package body Ada.Containers.Ordered_Maps is function First_Element (Container : Map) return Element_Type is T : Tree_Type renames Container.Tree; - begin if T.First = null then raise Constraint_Error with "map is empty"; @@ -827,21 +855,76 @@ package body Ada.Containers.Ordered_Maps is end Iterate; function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class + (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class is - Node : constant Node_Access := Container.Tree.First; - It : constant Iterator := (Container'Unrestricted_Access, Node); + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; begin - return It; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + B := B + 1; + end return; end Iterate; function Iterate (Container : Map; Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'class + return Map_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unrestricted_Access, Start.Node); + B : Natural renames Container.Tree'Unrestricted_Access.all.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + B := B + 1; + end return; end Iterate; --------- @@ -876,13 +959,24 @@ package body Ada.Containers.Ordered_Maps is end Last; function Last (Object : Iterator) return Cursor is - M : constant Map_Access := Object.Container; - N : constant Node_Access := M.Tree.Last; begin - if N = null then - return No_Element; + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; else - return Cursor'(Object.Container.all'Unchecked_Access, N); + return Cursor'(Object.Container, Object.Node); end if; end Last; @@ -980,11 +1074,16 @@ package body Ada.Containers.Ordered_Maps is Position : Cursor) return Cursor is begin - if Position.Node = null then + if Position.Container = null then return No_Element; - else - return (Object.Container, Tree_Operations.Next (Position.Node)); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); end Next; ------------ @@ -1032,12 +1131,18 @@ package body Ada.Containers.Ordered_Maps is Position : Cursor) return Cursor is begin - if Position.Node = null then + if Position.Container = null then return No_Element; - else - return (Object.Container, Tree_Operations.Previous (Position.Node)); end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong map"; + end if; + + return Previous (Position); end Previous; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index 53942b71fa2..9d2737a5efb 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -203,19 +203,23 @@ package Ada.Containers.Ordered_Maps is (Container : Map; Process : not null access procedure (Position : Cursor)); + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + -- The map container supports iteration in both the forward and reverse + -- directions, hence these constructor functions return an object that + -- supports the Reversible_Iterator interface. + function Iterate (Container : Map) - return Map_Iterator_Interfaces.Forward_Iterator'class; + return Map_Iterator_Interfaces.Reversible_Iterator'class; function Iterate (Container : Map; Start : Cursor) return Map_Iterator_Interfaces.Reversible_Iterator'class; - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - private pragma Inline (Next); diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 4c6476864b8..b4518f40b75 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -42,15 +42,17 @@ with System; use type System.Address; package body Ada.Containers.Ordered_Sets is - type Iterator is new - Ordered_Set_Iterator_Interfaces.Reversible_Iterator with record - Container : access constant Set; - Node : Node_Access; - end record; + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record; - overriding function First (Object : Iterator) return Cursor; + overriding procedure Finalize (Object : in out Iterator); - overriding function Last (Object : Iterator) return Cursor; + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; overriding function Next (Object : Iterator; @@ -512,6 +514,22 @@ package body Ada.Containers.Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + declare + B : Natural renames Object.Container.all.Tree.Busy; + + begin + B := B - 1; + end; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -537,9 +555,24 @@ package body Ada.Containers.Ordered_Sets is function First (Object : Iterator) return Cursor is begin - return (if Object.Container = null then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Tree.First)); + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; end First; ------------------- @@ -1145,7 +1178,7 @@ package body Ada.Containers.Ordered_Sets is Process (Cursor'(Container'Unrestricted_Access, Node)); end Process_Node; - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; B : Natural renames T.Busy; -- Start of processing for Iterate @@ -1165,22 +1198,74 @@ package body Ada.Containers.Ordered_Sets is end Iterate; function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin - if Container.Length = 0 then - return Iterator'(null, null); - else - return Iterator'(Container'Unchecked_Access, Container.Tree.First); - end if; + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null); end Iterate; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class + return Set_Iterator_Interfaces.Reversible_Iterator'Class is - It : constant Iterator := (Container'Unchecked_Access, Start.Node); + B : Natural renames Container'Unrestricted_Access.all.Tree.Busy; + begin - return It; + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + B := B + 1; + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node); end Iterate; ---------- @@ -1196,9 +1281,24 @@ package body Ada.Containers.Ordered_Sets is function Last (Object : Iterator) return Cursor is begin - return (if Object.Container = null then No_Element - else Cursor'(Object.Container.all'Unrestricted_Access, - Object.Container.Tree.Last)); + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; end Last; ------------------ @@ -1271,8 +1371,16 @@ package body Ada.Containers.Ordered_Sets is end Next; function Next (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + return Next (Position); end Next; @@ -1322,8 +1430,16 @@ package body Ada.Containers.Ordered_Sets is end Previous; function Previous (Object : Iterator; Position : Cursor) return Cursor is - pragma Unreferenced (Object); begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + return Previous (Position); end Previous; diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 45e6ab90a73..39f69f5eff0 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -65,7 +65,7 @@ package Ada.Containers.Ordered_Sets is No_Element : constant Cursor; - package Ordered_Set_Iterator_Interfaces is new + package Set_Iterator_Interfaces is new Ada.Iterator_Interfaces (Cursor, Has_Element); type Constant_Reference_Type @@ -227,12 +227,12 @@ package Ada.Containers.Ordered_Sets is function Iterate (Container : Set) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; function Iterate (Container : Set; Start : Cursor) - return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class; + return Set_Iterator_Interfaces.Reversible_Iterator'class; generic type Key_Type (<>) is private; diff --git a/gcc/ada/a-exetim-posix.adb b/gcc/ada/a-exetim-posix.adb index 65b21d61d7a..094f2aab51f 100644 --- a/gcc/ada/a-exetim-posix.adb +++ b/gcc/ada/a-exetim-posix.adb @@ -34,6 +34,7 @@ with Ada.Task_Identification; use Ada.Task_Identification; with Ada.Unchecked_Conversion; +with System.OS_Constants; use System.OS_Constants; with System.OS_Interface; use System.OS_Interface; with Interfaces.C; use Interfaces.C; @@ -112,9 +113,6 @@ package body Ada.Execution_Time is pragma Import (C, clock_gettime, "clock_gettime"); -- Function from the POSIX.1b Realtime Extensions library - CLOCK_THREAD_CPUTIME_ID : constant := 3; - -- Identifier for the clock returning per-task CPU time - begin if T = Ada.Task_Identification.Null_Task_Id then raise Program_Error; diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads index d5cada210e2..b53fd2a8784 100644 --- a/gcc/ada/a-finali.ads +++ b/gcc/ada/a-finali.ads @@ -34,14 +34,16 @@ ------------------------------------------------------------------------------ pragma Warnings (Off); --- System.Finalization_Root does not have category Remote_Types, but we --- allow it anyway. with System.Finalization_Root; pragma Warnings (On); package Ada.Finalization is + pragma Pure_12; + -- Ada.Finalization is declared pure in Ada 2012 (AI05-0212) + pragma Preelaborate; pragma Remote_Types; + -- The above apply in versions of Ada before Ada 2012 type Controlled is abstract tagged private; pragma Preelaborable_Initialization (Controlled); diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 7e701f53c14..dde33429575 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2449,6 +2449,14 @@ __gnat_dup2 (int oldfd, int newfd) /* Not supported on VxWorks 5.x, but supported on VxWorks 6.0 when using RTPs. */ return -1; +#elif defined (_WIN32) + /* Special case when oldfd and newfd are identical and are the standard + input, output or error as this makes Windows XP hangs. Note that we + do that only for standard file descriptors that are known to be valid. */ + if (oldfd == newfd && newfd >= 0 && newfd <= 2) + return newfd; + else + return dup2 (oldfd, newfd); #else return dup2 (oldfd, newfd); #endif diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 9b707734b76..7cc218e1d98 100755 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -180,6 +180,7 @@ package body Aspects is N_Component_Declaration => True, N_Entry_Declaration => True, N_Exception_Declaration => True, + N_Exception_Renaming_Declaration => True, N_Formal_Abstract_Subprogram_Declaration => True, N_Formal_Concrete_Subprogram_Declaration => True, N_Formal_Object_Declaration => True, @@ -188,11 +189,14 @@ package body Aspects is N_Full_Type_Declaration => True, N_Function_Instantiation => True, N_Generic_Package_Declaration => True, + N_Generic_Renaming_Declaration => True, N_Generic_Subprogram_Declaration => True, N_Object_Declaration => True, + N_Object_Renaming_Declaration => True, N_Package_Declaration => True, N_Package_Instantiation => True, N_Package_Specification => True, + N_Package_Renaming_Declaration => True, N_Private_Extension_Declaration => True, N_Private_Type_Declaration => True, N_Procedure_Instantiation => True, @@ -202,6 +206,7 @@ package body Aspects is N_Single_Task_Declaration => True, N_Subprogram_Body => True, N_Subprogram_Declaration => True, + N_Subprogram_Renaming_Declaration => True, N_Subtype_Declaration => True, N_Task_Body => True, N_Task_Type_Declaration => True, @@ -255,6 +260,7 @@ package body Aspects is Aspect_Preelaborate_05 => Aspect_Preelaborate_05, Aspect_Pure => Aspect_Pure, Aspect_Pure_05 => Aspect_Pure_05, + Aspect_Pure_12 => Aspect_Pure_12, Aspect_Remote_Call_Interface => Aspect_Remote_Call_Interface, Aspect_Remote_Types => Aspect_Remote_Types, Aspect_Shared_Passive => Aspect_Shared_Passive, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 582a71e7a55..c1dbe72cd3f 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -96,6 +96,7 @@ package Aspects is Aspect_Preelaborate_05, -- GNAT Aspect_Pure, Aspect_Pure_05, -- GNAT + Aspect_Pure_12, -- GNAT Aspect_Remote_Call_Interface, Aspect_Remote_Types, Aspect_Shared_Passive, @@ -154,6 +155,7 @@ package Aspects is Aspect_Compiler_Unit => True, Aspect_Preelaborate_05 => True, Aspect_Pure_05 => True, + Aspect_Pure_12 => True, Aspect_Universal_Data => True, Aspect_Ada_2005 => True, Aspect_Ada_2012 => True, @@ -324,6 +326,7 @@ package Aspects is Aspect_Priority => Name_Priority, Aspect_Pure => Name_Pure, Aspect_Pure_05 => Name_Pure_05, + Aspect_Pure_12 => Name_Pure_12, Aspect_Pure_Function => Name_Pure_Function, Aspect_Read => Name_Read, Aspect_Remote_Call_Interface => Name_Remote_Call_Interface, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 67febfe1919..01f240fc034 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -442,7 +442,7 @@ package body Checks is -- are cases (e.g. with pragma Debug) where generating the checks -- can cause real trouble). - if not Expander_Active then + if not Full_Expander_Active then return; end if; @@ -878,7 +878,7 @@ package body Checks is if Backend_Overflow_Checks_On_Target or else not Do_Overflow_Check (N) - or else not Expander_Active + or else not Full_Expander_Active or else (Present (Parent (N)) and then Nkind (Parent (N)) = N_Type_Conversion and then Integer_Promotion_Possible (Parent (N))) @@ -1178,7 +1178,7 @@ package body Checks is -- Nothing to do if discriminant checks are suppressed or else no code -- is to be generated - if not Expander_Active + if not Full_Expander_Active or else Discriminant_Checks_Suppressed (T_Typ) then return; @@ -1462,7 +1462,7 @@ package body Checks is -- Don't actually use this value begin - if Expander_Active + if Full_Expander_Active and then not Backend_Divide_Checks_On_Target and then Check_Needed (Right, Division_Check) then @@ -2118,7 +2118,7 @@ package body Checks is (not Length_Checks_Suppressed (Target_Typ)); begin - if not Expander_Active then + if not Full_Expander_Active then return; end if; @@ -2226,7 +2226,7 @@ package body Checks is (not Range_Checks_Suppressed (Target_Typ)); begin - if not Expander_Active or else not Checks_On then + if not Full_Expander_Active or else not Checks_On then return; end if; @@ -5309,7 +5309,7 @@ package body Checks is -- enhanced to check for an always True value in the condition and to -- generate a compilation warning??? - if not Expander_Active or else not Checks_On then + if not Full_Expander_Active or else not Checks_On then return; end if; @@ -5673,6 +5673,22 @@ package body Checks is return; end if; + -- No check needed for the Get_Current_Excep.all.all idiom generated by + -- the expander within exception handlers, since we know that the value + -- can never be null. + + -- Is this really the right way to do this? Normally we generate such + -- code in the expander with checks off, and that's how we suppress this + -- kind of junk check ??? + + if Nkind (N) = N_Function_Call + and then Nkind (Name (N)) = N_Explicit_Dereference + and then Nkind (Prefix (Name (N))) = N_Identifier + and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep) + then + return; + end if; + -- Otherwise install access check Insert_Action (N, @@ -6220,7 +6236,7 @@ package body Checks is -- Start of processing for Selected_Length_Checks begin - if not Expander_Active then + if not Full_Expander_Active then return Ret_Result; end if; @@ -6794,7 +6810,7 @@ package body Checks is -- Start of processing for Selected_Range_Checks begin - if not Expander_Active then + if not Full_Expander_Active then return Ret_Result; end if; diff --git a/gcc/ada/env.c b/gcc/ada/env.c index 1719684034a..31c878e7795 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -110,8 +110,6 @@ __gnat_getenv (char *name, int *len, char **value) #ifdef VMS -static char *to_host_path_spec (char *); - typedef struct _ile3 { unsigned short len, code; diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 5993132cf81..c40179a5f7a 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1286,30 +1286,37 @@ package body Errout is Cur := First_Error_Msg; 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) - then - Delete_Warning (Cur); + declare + CE : Error_Msg_Object renames Errors.Table (Cur); - -- If this is a continuation, delete previous messages + begin + if not CE.Deleted + and then + (Warning_Specifically_Suppressed (CE.Sptr, CE.Text) + or else + Warning_Specifically_Suppressed (CE.Optr, CE.Text)) + then + Delete_Warning (Cur); - F := Cur; - while Errors.Table (F).Msg_Cont loop - F := Errors.Table (F).Prev; - Delete_Warning (F); - end loop; + -- If this is a continuation, delete previous messages - -- Delete any following continuations + F := Cur; + while Errors.Table (F).Msg_Cont loop + F := Errors.Table (F).Prev; + Delete_Warning (F); + end loop; - 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; + -- 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; + end; Cur := Errors.Table (Cur).Next; end loop; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 5c1c92ce6b5..ea83a8a7b45 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -771,7 +771,8 @@ package Errout is procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String; - Config : Boolean) + Config : Boolean; + Used : Boolean := False) renames Erroutc.Set_Specific_Warning_Off; -- This is called in response to the two argument form of pragma Warnings -- where the first argument is OFF, and the second argument is the prefix diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 649238018a1..f58a49a8a5a 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -1081,7 +1081,8 @@ package body Erroutc is procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String; - Config : Boolean) + Config : Boolean; + Used : Boolean := False) is begin Specific_Warnings.Append @@ -1089,7 +1090,7 @@ package body Erroutc is Msg => new String'(Msg), Stop => Source_Last (Current_Source_File), Open => True, - Used => False, + Used => Used, Config => Config)); end Set_Specific_Warning_Off; @@ -1135,16 +1136,16 @@ package body Erroutc is procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is begin - -- Don't bother with entries from instantiation copies, since we - -- will already have a copy in the template, which is what matters + -- Don't bother with entries from instantiation copies, since we will + -- already have a copy in the template, which is what matters. if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then return; end if; - -- If last entry in table already covers us, this is a redundant - -- pragma Warnings (Off) and can be ignored. This also handles the - -- case where all warnings are suppressed by command line switch. + -- If last entry in table already covers us, this is a redundant pragma + -- Warnings (Off) and can be ignored. This also handles the case where + -- all warnings are suppressed by command line switch. if Warnings.Last >= Warnings.First and then Warnings.Table (Warnings.Last).Start <= Loc @@ -1152,9 +1153,9 @@ package body Erroutc is then return; - -- Otherwise establish a new entry, extending from the location of - -- the pragma to the end of the current source file. This ending - -- point will be adjusted by a subsequent pragma Warnings (On). + -- Otherwise establish a new entry, extending from the location of the + -- pragma to the end of the current source file. This ending point will + -- be adjusted by a subsequent pragma Warnings (On). else Warnings.Increment_Last; @@ -1170,8 +1171,8 @@ package body Erroutc is procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is begin - -- Don't bother with entries from instantiation copies, since we - -- will already have a copy in the template, which is what matters + -- Don't bother with entries from instantiation copies, since we will + -- already have a copy in the template, which is what matters. if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then return; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index a2ac46329d4..6c077b0f2e3 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -445,7 +445,8 @@ package Erroutc is procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String; - Config : Boolean); + Config : Boolean; + Used : Boolean := False); -- This is called in response to the two argument form of pragma Warnings -- where the first argument is OFF, and the second argument is a string -- which identifies a specific warning to be suppressed. The first argument @@ -453,6 +454,8 @@ package Erroutc is -- string from the pragma. Loc is the location of the pragma (which is the -- start of the range to suppress). Config is True for the configuration -- pragma case (where there is no requirement for a matching OFF pragma). + -- Used is set True to disable the check that the warning actually has + -- has the effect of suppressing a warning. procedure Set_Specific_Warning_On (Loc : Source_Ptr; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 57e94d29840..ac6fdf9f26e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2117,21 +2117,38 @@ package body Exp_Attr is -- computation to be completed in the back-end, since we don't know what -- layout will be chosen. - when Attribute_First_Bit => First_Bit : declare + when Attribute_First_Bit => First_Bit_Attr : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin - if Known_Static_Component_Bit_Offset (CE) then + -- In Ada 2005 (or later) if we have the standard nondefault + -- bit order, then we return the original value as given in + -- the component clause (RM 2005 13.5.2(3/2)). + + if Present (Component_Clause (CE)) + and then Ada_Version >= Ada_2005 + and then not Reverse_Bit_Order (Scope (CE)) + then Rewrite (N, Make_Integer_Literal (Loc, - Component_Bit_Offset (CE) mod System_Storage_Unit)); + Intval => Expr_Value (First_Bit (Component_Clause (CE))))); + Analyze_And_Resolve (N, Typ); + + -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order), + -- rewrite with normalized value if we know it statically. + elsif Known_Static_Component_Bit_Offset (CE) then + Rewrite (N, + Make_Integer_Literal (Loc, + Component_Bit_Offset (CE) mod System_Storage_Unit)); Analyze_And_Resolve (N, Typ); + -- Otherwise left to back end, just do universal integer checks + else Apply_Universal_Integer_Attribute_Checks (N); end if; - end First_Bit; + end First_Bit_Attr; ----------------- -- Fixed_Value -- @@ -2680,24 +2697,41 @@ package body Exp_Attr is -- the computation up to the back end, since we don't know what layout -- will be chosen. - when Attribute_Last_Bit => Last_Bit : declare + when Attribute_Last_Bit => Last_Bit_Attr : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin - if Known_Static_Component_Bit_Offset (CE) + -- In Ada 2005 (or later) if we have the standard nondefault + -- bit order, then we return the original value as given in + -- the component clause (RM 2005 13.5.2(4/2)). + + if Present (Component_Clause (CE)) + and then Ada_Version >= Ada_2005 + and then not Reverse_Bit_Order (Scope (CE)) + then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Expr_Value (Last_Bit (Component_Clause (CE))))); + Analyze_And_Resolve (N, Typ); + + -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order), + -- rewrite with normalized value if we know it statically. + + elsif Known_Static_Component_Bit_Offset (CE) and then Known_Static_Esize (CE) then Rewrite (N, Make_Integer_Literal (Loc, Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit) + Esize (CE) - 1)); - Analyze_And_Resolve (N, Typ); + -- Otherwise leave to back end, just apply universal integer checks + else Apply_Universal_Integer_Attribute_Checks (N); end if; - end Last_Bit; + end Last_Bit_Attr; ------------------ -- Leading_Part -- @@ -2955,6 +2989,52 @@ package body Exp_Attr is Analyze_And_Resolve (N, Typ); end Mantissa; + ---------------------------------- + -- Max_Size_In_Storage_Elements -- + ---------------------------------- + + when Attribute_Max_Size_In_Storage_Elements => + Apply_Universal_Integer_Attribute_Checks (N); + + -- Heap-allocated controlled objects contain two extra pointers which + -- are not part of the actual type. Transform the attribute reference + -- into a runtime expression to add the size of the hidden header. + + -- Do not perform this expansion on .NET/JVM targets because the + -- two pointers are already present in the type. + + if VM_Target = No_VM + and then Nkind (N) = N_Attribute_Reference + and then Needs_Finalization (Ptyp) + and then not Header_Size_Added (N) + then + Set_Header_Size_Added (N); + + -- Generate: + -- P'Max_Size_In_Storage_Elements + + -- Universal_Integer + -- (Header_Size_With_Padding (Ptyp'Alignment)) + + Rewrite (N, + Make_Op_Add (Loc, + Left_Opnd => Relocate_Node (N), + Right_Opnd => + Convert_To (Universal_Integer, + Make_Function_Call (Loc, + Name => + New_Reference_To + (RTE (RE_Header_Size_With_Padding), Loc), + + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To (Ptyp, Loc), + Attribute_Name => Name_Alignment)))))); + + Analyze (N); + return; + end if; + -------------------- -- Mechanism_Code -- -------------------- @@ -3495,21 +3575,41 @@ package body Exp_Attr is -- the computation up to the back end, since we don't know what layout -- will be chosen. - when Attribute_Position => Position : + when Attribute_Position => Position_Attr : declare CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin if Present (Component_Clause (CE)) then - Rewrite (N, - Make_Integer_Literal (Loc, - Intval => Component_Bit_Offset (CE) / System_Storage_Unit)); + + -- In Ada 2005 (or later) if we have the standard nondefault + -- bit order, then we return the original value as given in + -- the component clause (RM 2005 13.5.2(2/2)). + + if Ada_Version >= Ada_2005 + and then not Reverse_Bit_Order (Scope (CE)) + then + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Expr_Value (Position (Component_Clause (CE))))); + + -- Otherwise (Ada 83 or 95, or reverse bit order specified in + -- later Ada version), return the normalized value. + + else + Rewrite (N, + Make_Integer_Literal (Loc, + Intval => Component_Bit_Offset (CE) / System_Storage_Unit)); + end if; + Analyze_And_Resolve (N, Typ); + -- If back end is doing things, just apply universal integer checks + else Apply_Universal_Integer_Attribute_Checks (N); end if; - end Position; + end Position_Attr; ---------- -- Pred -- @@ -5518,8 +5618,7 @@ package body Exp_Attr is -- that the result is in range. when Attribute_Aft | - Attribute_Max_Alignment_For_Allocation | - Attribute_Max_Size_In_Storage_Elements => + Attribute_Max_Alignment_For_Allocation => Apply_Universal_Integer_Attribute_Checks (N); -- The following attributes should not appear at this stage, since they diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index fd75b158449..d7f30991fca 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3178,11 +3178,13 @@ package body Exp_Ch5 is -- Determine the advancement and initialization steps for the -- cursor. - -- Must verify that the container has a reverse iterator ??? + -- Analysis of the expanded loop will verify that the container + -- has a reverse iterator. if Reverse_Present (I_Spec) then Name_Init := Name_Last; Name_Step := Name_Previous; + else Name_Init := Name_First; Name_Step := Name_Next; @@ -3231,7 +3233,7 @@ package body Exp_Ch5 is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Pack, Loc), Selector_Name => - Make_Identifier (Loc, Name_Has_Element)), + Make_Identifier (Loc, Name_Has_Element)), Parameter_Associations => New_List ( @@ -3248,20 +3250,19 @@ package body Exp_Ch5 is -- I : Iterator_Type renames Container; -- C : Pack.Cursor_Type := Container.[First | Last]; - declare - Decl1 : Node_Id; - Decl2 : Node_Id; + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Iterator, + Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), + Name => Relocate_Node (Name (I_Spec)))); - begin - Decl1 := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Iterator, - Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), - Name => Relocate_Node (Name (I_Spec))); + -- Create declaration for cursor - -- Create declaration for cursor + declare + Decl : Node_Id; - Decl2 := + begin + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Cursor, Object_Definition => @@ -3272,18 +3273,15 @@ package body Exp_Ch5 is Selector_Name => Make_Identifier (Loc, Name_Init))); - Set_Assignment_OK (Decl2); - - Insert_Actions (N, New_List (Decl1, Decl2)); - end; + -- The cursor is only modified in expanded code, so it appears + -- as unassigned to the warning machinery. We must suppress + -- this spurious warning explicitly. - -- The Iterator is not modified in the source, but of course will - -- be updated in the generated code. Indicate that it is actually - -- set to prevent spurious warnings. Ditto for the Cursor, which - -- is modified indirectly in generated code. + Set_Warnings_Off (Cursor); + Set_Assignment_OK (Decl); - Set_Never_Set_In_Source (Iterator, False); - Set_Never_Set_In_Source (Cursor, False); + Insert_Action (N, Decl); + end; -- If the range of iteration is given by a function call that -- returns a container, the finalization actions have been saved diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6049c452cb8..4c9460438d3 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1750,24 +1750,50 @@ package body Exp_Ch6 is if not Is_Empty_List (Post_Call) then - -- If call is not a list member, it must be the triggering statement - -- of a triggering alternative or an entry call alternative, and we - -- can add the post call stuff to the corresponding statement list. + -- Cases where the call is not a member of a statement list if not Is_List_Member (N) then declare - P : constant Node_Id := Parent (N); + P : Node_Id := Parent (N); begin - pragma Assert (Nkind_In (P, N_Triggering_Alternative, - N_Entry_Call_Alternative)); + -- In Ada 2012 the call may be a function call in an expression + -- (since OUT and IN OUT parameters are now allowed for such + -- calls. The write-back of (in)-out parameters is handled + -- by the back-end, but the constraint checks generated when + -- subtypes of formal and actual don't match must be inserted + -- in the form of assignments, at the nearest point after the + -- declaration or statement that contains the call. + + if Ada_Version >= Ada_2012 + and then Nkind (N) = N_Function_Call + then + while Nkind (P) not in N_Declaration + and then + Nkind (P) not in N_Statement_Other_Than_Procedure_Call + loop + P := Parent (P); + end loop; + + Insert_Actions_After (P, Post_Call); + + -- If not the special Ada 2012 case of a function call, then + -- we must have the triggering statement of a triggering + -- alternative or an entry call alternative, and we can add + -- the post call stuff to the corresponding statement list. - if Is_Non_Empty_List (Statements (P)) then - Insert_List_Before_And_Analyze - (First (Statements (P)), Post_Call); else - Set_Statements (P, Post_Call); + pragma Assert (Nkind_In (P, N_Triggering_Alternative, + N_Entry_Call_Alternative)); + + if Is_Non_Empty_List (Statements (P)) then + Insert_List_Before_And_Analyze + (First (Statements (P)), Post_Call); + else + Set_Statements (P, Post_Call); + end if; end if; + end; -- Otherwise, normal case where N is in a statement sequence, @@ -2764,7 +2790,7 @@ package body Exp_Ch6 is Next_Formal (Formal); end loop; - -- If we are calling an Ada2012 function which needs to have the + -- If we are calling an Ada 2012 function which needs to have the -- "accessibility level determined by the point of call" (AI05-0234) -- passed in to it, then pass it in. @@ -6674,6 +6700,14 @@ package body Exp_Ch6 is Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc))); + -- Ada 2005 (AI-251): If the type of the returned object is + -- an interface then add an implicit type conversion to force + -- displacement of the "this" pointer. + + if Is_Interface (R_Type) then + Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); + end if; + Analyze_And_Resolve (Exp, R_Type); end; @@ -7779,6 +7813,15 @@ package body Exp_Ch6 is -- to the object created by the allocator). Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call))); + + -- Ada 2005 (AI-251): If the type of the allocator is an interface then + -- generate an implicit conversion to force displacement of the "this" + -- pointer. + + if Is_Interface (Designated_Type (Acc_Type)) then + Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); + end if; + Analyze_And_Resolve (Allocator, Acc_Type); end Make_Build_In_Place_Call_In_Allocator; @@ -7954,6 +7997,7 @@ package body Exp_Ch6 is Obj_Id : Entity_Id; Ptr_Typ : Entity_Id; Ptr_Typ_Decl : Node_Id; + New_Expr : Node_Id; Result_Subt : Entity_Id; Target : Node_Id; @@ -8033,16 +8077,20 @@ package body Exp_Ch6 is Insert_After_And_Analyze (Assign, Ptr_Typ_Decl); -- Finally, create an access object initialized to a reference to the - -- function call. + -- function call. We know this access value is non-null, so mark the + -- entity accordingly to suppress junk access checks. + + New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); - Obj_Id := Make_Temporary (Loc, 'R'); + Obj_Id := Make_Temporary (Loc, 'R', New_Expr); Set_Etype (Obj_Id, Ptr_Typ); + Set_Is_Known_Non_Null (Obj_Id); Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, Object_Definition => New_Reference_To (Ptr_Typ, Loc), - Expression => Make_Reference (Loc, Relocate_Node (Func_Call))); + Expression => New_Expr); Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl); Rewrite (Assign, Make_Null_Statement (Loc)); @@ -8295,12 +8343,14 @@ package body Exp_Ch6 is end if; -- Finally, create an access object initialized to a reference to the - -- function call. + -- function call. We know this access value cannot be null, so mark the + -- entity accordingly to suppress the access check. New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call)); Def_Id := Make_Temporary (Loc, 'R', New_Expr); Set_Etype (Def_Id, Ref_Type); + Set_Is_Known_Non_Null (Def_Id); Insert_After_And_Analyze (Ptr_Typ_Decl, Make_Object_Declaration (Loc, @@ -8499,8 +8549,8 @@ package body Exp_Ch6 is return False; -- Handle a corner case, a cross-dialect subp renaming. For example, - -- an Ada2012 renaming of an Ada05 subprogram. This can occur when a - -- non-Ada2012 unit references predefined runtime units. + -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when + -- an Ada 2005 (or earlier) unit references predefined run-time units. elsif Present (Alias (Func_Id)) then diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 78d9b006abc..c8529ce2a51 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -245,7 +245,10 @@ package body Exp_Imgv is -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is -- when pragma Discard_Names applies, in which case we replace expr by: - -- Missing ??? + -- (rt'Pos (expr))'Img + + -- So that the result is a space followed by the decimal value for the + -- position of the enumeration value in the enumeration type. procedure Expand_Image_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -368,7 +371,7 @@ package body Exp_Imgv is or else No (Lit_Strings (Root_Type (Ptyp))) then -- When pragma Discard_Names applies to the first subtype, build - -- (Pref'Pos)'Img. + -- (Pref'Pos (Expr))'Img. Rewrite (N, Make_Attribute_Reference (Loc, @@ -1055,9 +1058,14 @@ package body Exp_Imgv is -- typ'Pos (Typ'Last)) -- Wide_Character_Encoding_Method); - -- where typS and typI are the enumeration image strings and - -- indexes table, as described in Build_Enumeration_Image_Tables. - -- NN is 8/16/32 for depending on the element type for typI. + -- where typS and typI are the enumeration image strings and indexes + -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32 + -- for depending on the element type for typI. + + -- Finally if Discard_Names is in effect for an enumeration type, then + -- a special conditional expression is built that yields the space needed + -- for the decimal representation of the largest pos value in the subtype. + -- See code below for details. procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is Loc : constant Source_Ptr := Sloc (N); @@ -1065,10 +1073,10 @@ package body Exp_Imgv is Pref : constant Node_Id := Prefix (N); Ptyp : constant Entity_Id := Etype (Pref); Rtyp : constant Entity_Id := Root_Type (Ptyp); - XX : RE_Id; - YY : Entity_Id; Arglist : List_Id; Ttyp : Entity_Id; + XX : RE_Id; + YY : Entity_Id; begin -- Types derived from Standard.Boolean @@ -1125,7 +1133,6 @@ package body Exp_Imgv is -- Real types elsif Is_Real_Type (Rtyp) then - Rewrite (N, Make_Conditional_Expression (Loc, Expressions => New_List ( @@ -1155,21 +1162,113 @@ package body Exp_Imgv is else pragma Assert (Is_Enumeration_Type (Rtyp)); - if Discard_Names (Rtyp) then + -- Whenever pragma Discard_Names is in effect, the value we need + -- is the value needed to accomodate the largest integer pos value + -- in the range of the subtype + 1 for the space at the start. We + -- build: - -- This is a configurable run-time, or else a restriction is in - -- effect. In either case the attribute cannot be supported. Force - -- a load error from Rtsfind to generate an appropriate message, - -- as is done with other ZFP violations. + -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last) + -- and replace the expression by + + -- (if Ptyp'Range_Length = 0 then 0 + -- else (if Tnn < 10 then 2 + -- else (if Tnn < 100 then 3 + -- ... + -- else n)))... + + -- where n is equal to Rtyp'Pos (Rtyp'Last) + 1 + + -- Note: The above processing is in accordance with the intent of + -- the RM, which is that Width should be related to the impl-defined + -- behavior of Image. It is not clear what this means if Image is + -- not defined (as in the configurable run-time case for GNAT) and + -- gives an error at compile time. + + -- We choose in this case to just go ahead and implement Width the + -- same way, returning what Image would have returned if it has been + -- available in the configurable run-time library. + + if Discard_Names (Rtyp) then declare - Discard : constant Entity_Id := RTE (RE_Null); - pragma Unreferenced (Discard); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T'); + Cexpr : Node_Id; + P : Int; + M : Int; + K : Int; + begin + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Integer, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Rtyp, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Last))))); + + -- OK, now we need to build the conditional expression. First + -- get the value of M, the largest possible value needed. + + P := UI_To_Int + (Enumeration_Pos (Entity (Type_High_Bound (Rtyp)))); + + K := 1; + M := 1; + while M < P loop + M := M * 10; + K := K + 1; + end loop; + + -- Build inner else + + Cexpr := Make_Integer_Literal (Loc, K); + + -- Wrap in inner if's until counted down to 2 + + while K > 2 loop + M := M / 10; + K := K - 1; + + Cexpr := + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Lt (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => Make_Integer_Literal (Loc, M)), + Make_Integer_Literal (Loc, K), + Cexpr)); + end loop; + + -- Add initial comparison for null range and we are done, so + -- rewrite the attribute occurrence with this expression. + + Rewrite (N, + Convert_To (Typ, + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ptyp, Loc), + Attribute_Name => Name_Range_Length), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Make_Integer_Literal (Loc, 0), + Cexpr)))); + + Analyze_And_Resolve (N, Typ); return; end; end if; + -- Normal case, not Discard_Names + Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp))); case Attr is diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index ce7c0dcc979..b116a8a28f0 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1123,6 +1123,10 @@ package body Exp_Intr is D_Type : Entity_Id; begin + -- Perform minor decoration as it is needed by the side effect + -- removal mechanism. + + Set_Etype (Deref, Desig_T); Set_Parent (Deref, Free_Node); D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 22e9bb04691..8cb084d6ba2 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -270,10 +270,17 @@ package body Exp_Prag is procedure Expand_Pragma_Check (N : Node_Id) is Cond : constant Node_Id := Arg2 (N); - Loc : constant Source_Ptr := Sloc (Cond); Nam : constant Name_Id := Chars (Arg1 (N)); Msg : Node_Id; + Loc : constant Source_Ptr := Sloc (First_Node (Cond)); + -- Source location used in the case of a failed assertion. Note that + -- the source location of the expression is not usually the best choice + -- here. For example, it gets located on the last AND keyword in a + -- chain of boolean expressiond AND'ed together. It is best to put the + -- message on the first character of the assertion, which is the effect + -- of the First_Node call here. + begin -- We already know that this check is enabled, because otherwise the -- semantic pass dealt with rewriting the assertion (see Sem_Prag) diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e675da82889..c67d0117897 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6424,13 +6424,14 @@ package body Exp_Util is if not Expander_Active then return; + end if; -- Cannot generate temporaries if the invocation to remove side effects -- was issued too early and the type of the expression is not resolved -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke -- Remove_Side_Effects). - elsif No (Exp_Type) + if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then return; @@ -6710,8 +6711,13 @@ package body Exp_Util is if Alfa_Mode then New_Exp := E; + + -- Otherwise generate reference, marking the value as non-null + -- since we know it cannot be null and we don't want a check. + else New_Exp := Make_Reference (Loc, E); + Set_Is_Known_Non_Null (Def_Id); end if; end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index b1a33d58da1..16521f9f6d7 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1342,7 +1342,9 @@ package body Freeze is -- If an incomplete type is still not frozen, this may be a -- premature freezing because of a body declaration that follows. - -- Indicate where the freezing took place. + -- Indicate where the freezing took place. Freezing will happen + -- if the body comes from source, but not if it is internally + -- generated, for example as the body of a type invariant. -- If the freezing is caused by the end of the current declarative -- part, it is a Taft Amendment type, and there is no error. @@ -1360,8 +1362,9 @@ package body Freeze is N_Protected_Body, N_Task_Body) or else Nkind (Bod) in N_Body_Stub) - and then - List_Containing (After) = List_Containing (Parent (E)) + and then + List_Containing (After) = List_Containing (Parent (E)) + and then Comes_From_Source (Bod) then Error_Msg_Sloc := Sloc (Next (After)); Error_Msg_NE @@ -4239,7 +4242,8 @@ package body Freeze is -- By default, if no size clause is present, an enumeration type with -- Convention C is assumed to interface to a C enum, and has integer -- size. This applies to types. For subtypes, verify that its base - -- type has no size clause either. + -- type has no size clause either. Treat other foreign conventions + -- in the same way, and also make sure alignment is set right. if Has_Foreign_Convention (Typ) and then not Has_Size_Clause (Typ) @@ -4247,6 +4251,7 @@ package body Freeze is and then Esize (Typ) < Standard_Integer_Size then Init_Esize (Typ, Standard_Integer_Size); + Set_Alignment (Typ, Alignment (Standard_Integer)); else -- If the enumeration type interfaces to C, and it has a size clause diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 2dad57a3b3b..35e7d9e769b 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -226,6 +226,12 @@ begin Opt.Suppress_Options := Scope_Suppress; end; + -- This is where we can capture the value of the compilation unit specific + -- restrictions that have been set by the config pragma files (or from + -- Targparm), for later restoration when processing e.g. subunits. + + Save_Config_Cunit_Boolean_Restrictions; + -- If there was a -gnatem switch, initialize the mappings of unit names to -- file names and of file names to path names from the mapping file. diff --git a/gcc/ada/g-exptty.adb b/gcc/ada/g-exptty.adb new file mode 100644 index 00000000000..7ec04727d07 --- /dev/null +++ b/gcc/ada/g-exptty.adb @@ -0,0 +1,309 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T . T T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2011, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with System; use System; + +package body GNAT.Expect.TTY is + + On_Windows : constant Boolean := Directory_Separator = '\'; + -- True when on Windows + + ----------- + -- Close -- + ----------- + + overriding procedure Close + (Descriptor : in out TTY_Process_Descriptor; + Status : out Integer) + is + procedure Terminate_Process (Process : System.Address); + pragma Import (C, Terminate_Process, "__gnat_terminate_process"); + + function Waitpid (Process : System.Address) return Integer; + pragma Import (C, Waitpid, "__gnat_waitpid"); + -- Wait for a specific process id, and return its exit code + + procedure Free_Process (Process : System.Address); + pragma Import (C, Free_Process, "__gnat_free_process"); + + procedure Close_TTY (Process : System.Address); + pragma Import (C, Close_TTY, "__gnat_close_tty"); + + begin + -- If we haven't already closed the process + + if Descriptor.Process = System.Null_Address then + Status := -1; + + else + if Descriptor.Input_Fd /= Invalid_FD then + Close (Descriptor.Input_Fd); + end if; + + if Descriptor.Error_Fd /= Descriptor.Output_Fd + and then Descriptor.Error_Fd /= Invalid_FD + then + Close (Descriptor.Error_Fd); + end if; + + if Descriptor.Output_Fd /= Invalid_FD then + Close (Descriptor.Output_Fd); + end if; + + -- Send a Ctrl-C to the process first. This way, if the + -- launched process is a "sh" or "cmd", the child processes + -- will get terminated as well. Otherwise, terminating the + -- main process brutally will leave the children running. + + Interrupt (Descriptor); + delay 0.05; + + Terminate_Process (Descriptor.Process); + Status := Waitpid (Descriptor.Process); + + if not On_Windows then + Close_TTY (Descriptor.Process); + end if; + + Free_Process (Descriptor.Process'Address); + Descriptor.Process := System.Null_Address; + + GNAT.OS_Lib.Free (Descriptor.Buffer); + Descriptor.Buffer_Size := 0; + end if; + end Close; + + overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is + Status : Integer; + begin + Close (Descriptor, Status); + end Close; + + ----------------------------- + -- Close_Pseudo_Descriptor -- + ----------------------------- + + procedure Close_Pseudo_Descriptor + (Descriptor : in out TTY_Process_Descriptor) + is + begin + Descriptor.Buffer_Size := 0; + GNAT.OS_Lib.Free (Descriptor.Buffer); + end Close_Pseudo_Descriptor; + + --------------- + -- Interrupt -- + --------------- + + overriding procedure Interrupt + (Descriptor : in out TTY_Process_Descriptor) + is + procedure Internal (Process : System.Address); + pragma Import (C, Internal, "__gnat_interrupt_process"); + begin + if Descriptor.Process /= System.Null_Address then + Internal (Descriptor.Process); + end if; + end Interrupt; + + procedure Interrupt (Pid : Integer) is + procedure Internal (Pid : Integer); + pragma Import (C, Internal, "__gnat_interrupt_pid"); + begin + Internal (Pid); + end Interrupt; + + ----------------------- + -- Pseudo_Descriptor -- + ----------------------- + + procedure Pseudo_Descriptor + (Descriptor : out TTY_Process_Descriptor'Class; + TTY : GNAT.TTY.TTY_Handle; + Buffer_Size : Natural := 4096) is + begin + Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY); + Descriptor.Output_Fd := Descriptor.Input_Fd; + + -- Create the buffer + + Descriptor.Buffer_Size := Buffer_Size; + + if Buffer_Size /= 0 then + Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); + end if; + end Pseudo_Descriptor; + + ---------- + -- Send -- + ---------- + + overriding procedure Send + (Descriptor : in out TTY_Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False) + is + Header : String (1 .. 5); + Length : Natural; + Ret : Natural; + + procedure Internal + (Process : System.Address; + S : in out String; + Length : Natural; + Ret : out Natural); + pragma Import (C, Internal, "__gnat_send_header"); + + begin + Length := Str'Length; + + if Add_LF then + Length := Length + 1; + end if; + + Internal (Descriptor.Process, Header, Length, Ret); + + if Ret = 1 then + + -- Need to use the header + + GNAT.Expect.Send + (Process_Descriptor (Descriptor), + Header & Str, Add_LF, Empty_Buffer); + + else + GNAT.Expect.Send + (Process_Descriptor (Descriptor), + Str, Add_LF, Empty_Buffer); + end if; + end Send; + + -------------- + -- Set_Size -- + -------------- + + procedure Set_Size + (Descriptor : in out TTY_Process_Descriptor'Class; + Rows : Natural; + Columns : Natural) + is + procedure Internal (Process : System.Address; R, C : Integer); + pragma Import (C, Internal, "__gnat_setup_winsize"); + begin + if Descriptor.Process /= System.Null_Address then + Internal (Descriptor.Process, Rows, Columns); + end if; + end Set_Size; + + --------------------------- + -- Set_Up_Communications -- + --------------------------- + + overriding procedure Set_Up_Communications + (Pid : in out TTY_Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type) + is + pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3); + + function Internal (Process : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_setup_communication"); + + begin + if Internal (Pid.Process'Address) /= 0 then + raise Invalid_Process with "cannot setup communication."; + end if; + end Set_Up_Communications; + + --------------------------------- + -- Set_Up_Child_Communications -- + --------------------------------- + + overriding procedure Set_Up_Child_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : String; + Args : System.Address) + is + pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd); + function Internal + (Process : System.Address; Argv : System.Address; Use_Pipes : Integer) + return Process_Id; + pragma Import (C, Internal, "__gnat_setup_child_communication"); + + begin + Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes)); + end Set_Up_Child_Communications; + + ---------------------------------- + -- Set_Up_Parent_Communications -- + ---------------------------------- + + overriding procedure Set_Up_Parent_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type) + is + pragma Unreferenced (Pipe1, Pipe2, Pipe3); + + procedure Internal + (Process : System.Address; + Inputfp : out File_Descriptor; + Outputfp : out File_Descriptor; + Errorfp : out File_Descriptor; + Pid : out Process_Id); + pragma Import (C, Internal, "__gnat_setup_parent_communication"); + + begin + Internal + (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid); + end Set_Up_Parent_Communications; + + ------------------- + -- Set_Use_Pipes -- + ------------------- + + procedure Set_Use_Pipes + (Descriptor : in out TTY_Process_Descriptor; + Use_Pipes : Boolean) is + begin + Descriptor.Use_Pipes := Use_Pipes; + end Set_Use_Pipes; + +end GNAT.Expect.TTY; diff --git a/gcc/ada/g-exptty.ads b/gcc/ada/g-exptty.ads new file mode 100644 index 00000000000..e218e0b5d54 --- /dev/null +++ b/gcc/ada/g-exptty.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T . T T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2011, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.TTY; + +with System; +with System.OS_Constants; + +package GNAT.Expect.TTY is + + pragma Linker_Options (System.OS_Constants.PTY_Library); + + ------------------ + -- TTY_Process -- + ------------------ + + type TTY_Process_Descriptor is new Process_Descriptor with private; + -- Similar to Process_Descriptor, with the parent set up as a full terminal + -- (Unix sense, see tty(4)). + + procedure Pseudo_Descriptor + (Descriptor : out TTY_Process_Descriptor'Class; + TTY : GNAT.TTY.TTY_Handle; + Buffer_Size : Natural := 4096); + -- Given a terminal descriptor (TTY), create a pseudo process descriptor + -- to be used with GNAT.Expect. + -- + -- Note that it is invalid to call Close, Interrupt, Send_Signal on the + -- resulting descriptor. To deallocate memory associated with Process, + -- call Close_Pseudo_Descriptor instead. + + procedure Close_Pseudo_Descriptor + (Descriptor : in out TTY_Process_Descriptor); + -- Free memory and ressources associated with Descriptor. Will *not* + -- close the associated TTY, it is the caller's responsibility to call + -- GNAT.TTY.Close_TTY. + + procedure Interrupt (Pid : Integer); + -- Interrupt a process given its pid + + overriding procedure Send + (Descriptor : in out TTY_Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False); + -- See parent + -- What does that comment mean??? what is "parent" here + + procedure Set_Use_Pipes + (Descriptor : in out TTY_Process_Descriptor; + Use_Pipes : Boolean); + -- Tell Expect.TTY whether to use Pipes or Console (on windows). Needs to + -- be set before spawning the process. Default is to use Pipes. + + procedure Set_Size + (Descriptor : in out TTY_Process_Descriptor'Class; + Rows : Natural; + Columns : Natural); + -- Sets up the size of the terminal as reported to the spawned process + +private + + -- All declarations in the private part must be fully commented ??? + + overriding procedure Close + (Descriptor : in out TTY_Process_Descriptor; + Status : out Integer); + + overriding procedure Close + (Descriptor : in out TTY_Process_Descriptor); + + overriding procedure Interrupt (Descriptor : in out TTY_Process_Descriptor); + -- When we use pseudo-terminals, we do not need to use signals to + -- interrupt the debugger, we can simply send the appropriate character. + -- This provides a better support for remote debugging for instance. + + procedure Set_Up_Communications + (Pid : in out TTY_Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type); + + procedure Set_Up_Parent_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type); + + procedure Set_Up_Child_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : String; + Args : System.Address); + + type TTY_Process_Descriptor is new Process_Descriptor with record + Process : System.Address; -- Underlying structure used in C + Use_Pipes : Boolean := True; + end record; + +end GNAT.Expect.TTY; diff --git a/gcc/ada/g-htable.ads b/gcc/ada/g-htable.ads index 11f1193d121..28745520645 100644 --- a/gcc/ada/g-htable.ads +++ b/gcc/ada/g-htable.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2011, 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,9 +37,7 @@ -- The Static_HTable package provides a more complex interface that allows -- complete control over allocation. --- Note: actual code is found in System.HTable (s-htable.ads/adb) since --- this facility is accessed from run time routines, but clients should --- always access the version supplied via GNAT.HTable. +-- See file s-htable.ads for full documentation of the interface pragma Compiler_Unit; @@ -51,177 +49,12 @@ package GNAT.HTable is -- The elaborate body is because we have a dummy body to deal with -- bootstrap path problems (we used to have a real body, and now we don't -- need it any more, but the bootstrap requires that we have a dummy body, - -- since otherwise the old body gets picked up. - - ------------------- - -- Simple_HTable -- - ------------------- - - -- A simple hash table abstraction, easy to instantiate, easy to use. - -- The table associates one element to one key with the procedure Set. - -- Get retrieves the Element stored for a given Key. The efficiency of - -- retrieval is function of the size of the Table parameterized by - -- Header_Num and the hashing function Hash. + -- since otherwise the old body gets picked up; also, we can't use pragma + -- No_Body because older bootstrap compilers don't support that). generic package Simple_HTable renames System.HTable.Simple_HTable; - - -- For convenience of reference here is what this package has in it: - - -- generic - -- type Header_Num is range <>; - -- -- An integer type indicating the number and range of hash headers - - -- type Element is private; - -- -- The type of element to be stored - - -- No_Element : Element; - -- -- The object that is returned by Get when no element has been set - -- -- for a given key - - -- type Key is private; - -- with function Hash (F : Key) return Header_Num; - -- with function Equal (F1, F2 : Key) return Boolean; - - -- package Simple_HTable is - - -- procedure Set (K : Key; E : Element); - -- -- Associates an element with a given key. Overrides any previously - -- -- associated element. - - -- procedure Reset; - -- -- Removes and frees all elements in the table - - -- function Get (K : Key) return Element; - -- -- Returns the Element associated with a key or No_Element if the - -- -- given key has not associated element - - -- procedure Remove (K : Key); - -- -- Removes the latest inserted element pointer associated with the - -- -- given key if any, does nothing if none. - - -- function Get_First return Element; - -- -- Returns No_Element if the HTable is empty, otherwise returns one - -- -- non specified element. There is no guarantee that two calls to - -- -- this function will return the same element. - - -- function Get_Next return Element; - -- -- Returns a non-specified element that has not been returned by the - -- -- same function since the last call to Get_First or No_Element if - -- -- there is no such element. If there is no call to 'Set' in between - -- -- Get_Next calls, all the elements of the HTable will be traversed. - - -- procedure Get_First (K : out Key; E : out Element); - -- -- This version of the iterator returns a key/element pair. A non- - -- -- specified entry is returned, and there is no guarantee that two - -- -- calls to this procedure will return the same element. - - -- procedure Get_Next (K : out Key; E : out Element); - -- -- This version of the iterator returns a key/element pair. It - -- -- returns a non-specified element that has not been returned since - -- -- the last call to Get_First. If there is no remaining element, - -- -- then E is set to No_Element, and the value in K is undefined. - -- -- If there is no call to Set in between Get_Next calls, all the - -- -- elements of the HTable will be traversed. - - -- end Simple_HTable; - - ------------------- - -- Static_HTable -- - ------------------- - - -- A low-level Hash-Table abstraction, not as easy to instantiate as - -- Simple_HTable but designed to allow complete control over the - -- allocation of necessary data structures. Particularly useful when - -- dynamic allocation is not desired. The model is that each Element - -- contains its own Key that can be retrieved by Get_Key. Furthermore, - -- Element provides a link that can be used by the HTable for linking - -- elements with same hash codes: - - -- Element - - -- +-------------------+ - -- | Key | - -- +-------------------+ - -- : other data : - -- +-------------------+ - -- | Next Elmt | - -- +-------------------+ - generic package Static_HTable renames System.HTable.Static_HTable; - -- For convenience of reference here is what this package has in it: - - -- generic - -- type Header_Num is range <>; - -- -- An integer type indicating the number and range of hash headers. - - -- type Element (<>) is limited private; - -- -- The type of element to be stored - - -- type Elmt_Ptr is private; - -- -- The type used to reference an element (will usually be an - -- -- access type, but could be some other form of type such as - -- -- an integer type). - - -- Null_Ptr : Elmt_Ptr; - -- -- The null value of the Elmt_Ptr type. - - -- with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - -- with function Next (E : Elmt_Ptr) return Elmt_Ptr; - -- -- The type must provide an internal link for the sake of the - -- -- staticness of the HTable. - - -- type Key is limited private; - -- with function Get_Key (E : Elmt_Ptr) return Key; - -- with function Hash (F : Key) return Header_Num; - -- with function Equal (F1, F2 : Key) return Boolean; - - -- package Static_HTable is - - -- procedure Reset; - -- -- Resets the hash table by setting all its elements to Null_Ptr. - -- -- The effect is to clear the hash table so that it can be reused. - -- -- For the most common case where Elmt_Ptr is an access type, and - -- -- Null_Ptr is null, this is only needed if the same table is - -- -- reused in a new context. If Elmt_Ptr is other than an access - -- -- type, or Null_Ptr is other than null, then Reset must be called - -- -- before the first use of the hash table. - - -- procedure Set (E : Elmt_Ptr); - -- -- Insert the element pointer in the HTable - - -- function Get (K : Key) return Elmt_Ptr; - -- -- Returns the latest inserted element pointer with the given Key - -- -- or null if none. - - -- procedure Remove (K : Key); - -- -- Removes the latest inserted element pointer associated with the - -- -- given key if any, does nothing if none. - - -- function Get_First return Elmt_Ptr; - -- -- Returns Null_Ptr if the HTable is empty, otherwise returns one - -- -- non specified element. There is no guarantee that two calls to - -- -- this function will return the same element. - - -- function Get_Next return Elmt_Ptr; - -- -- Returns a non-specified element that has not been returned by - -- -- the same function since the last call to Get_First or Null_Ptr - -- -- if there is no such element or Get_First has never been called. - -- -- If there is no call to 'Set' in between Get_Next calls, all - -- -- the elements of the HTable will be traversed. - - -- end Static_HTable; - - ---------- - -- Hash -- - ---------- - - -- A generic hashing function working on String keys - generic function Hash renames System.HTable.Hash; - -- generic - -- type Header_Num is range <>; - -- function Hash (Key : String) return Header_Num; - end GNAT.HTable; diff --git a/gcc/ada/g-tty.adb b/gcc/ada/g-tty.adb new file mode 100644 index 00000000000..43c1bea5469 --- /dev/null +++ b/gcc/ada/g-tty.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . T T Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2011, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C.Strings; use Interfaces.C.Strings; + +package body GNAT.TTY is + + use System; + + procedure Check_TTY (Handle : TTY_Handle); + -- Check the validity of Handle. Raise Program_Error if ttys are not + -- supported. Raise Constraint_Error if Handle is an invalid handle. + + ------------------ + -- Allocate_TTY -- + ------------------ + + procedure Allocate_TTY (Handle : out TTY_Handle) is + function Internal return System.Address; + pragma Import (C, Internal, "__gnat_new_tty"); + + begin + if not TTY_Supported then + raise Program_Error; + end if; + + Handle.Handle := Internal; + end Allocate_TTY; + + --------------- + -- Check_TTY -- + --------------- + + procedure Check_TTY (Handle : TTY_Handle) is + begin + if not TTY_Supported then + raise Program_Error; + elsif Handle.Handle = System.Null_Address then + raise Constraint_Error; + end if; + end Check_TTY; + + --------------- + -- Close_TTY -- + --------------- + + procedure Close_TTY (Handle : in out TTY_Handle) is + procedure Internal (Handle : System.Address); + pragma Import (C, Internal, "__gnat_close_tty"); + begin + Check_TTY (Handle); + Internal (Handle.Handle); + Handle.Handle := System.Null_Address; + end Close_TTY; + + --------------- + -- Reset_TTY -- + --------------- + + procedure Reset_TTY (Handle : TTY_Handle) is + procedure Internal (Handle : System.Address); + pragma Import (C, Internal, "__gnat_reset_tty"); + begin + Check_TTY (Handle); + Internal (Handle.Handle); + end Reset_TTY; + + -------------------- + -- TTY_Descriptor -- + -------------------- + + function TTY_Descriptor + (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor + is + function Internal + (Handle : System.Address) return GNAT.OS_Lib.File_Descriptor; + pragma Import (C, Internal, "__gnat_tty_fd"); + begin + Check_TTY (Handle); + return Internal (Handle.Handle); + end TTY_Descriptor; + + -------------- + -- TTY_Name -- + -------------- + + function TTY_Name (Handle : TTY_Handle) return String is + function Internal (Handle : System.Address) return chars_ptr; + pragma Import (C, Internal, "__gnat_tty_name"); + begin + Check_TTY (Handle); + return Value (Internal (Handle.Handle)); + end TTY_Name; + + ------------------- + -- TTY_Supported -- + ------------------- + + function TTY_Supported return Boolean is + function Internal return Integer; + pragma Import (C, Internal, "__gnat_tty_supported"); + begin + return Internal /= 0; + end TTY_Supported; + +end GNAT.TTY; diff --git a/gcc/ada/g-tty.ads b/gcc/ada/g-tty.ads new file mode 100644 index 00000000000..12aaba760f1 --- /dev/null +++ b/gcc/ada/g-tty.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . T T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2011, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides control over pseudo terminals (ttys) + +-- This package is only supported on unix systems. See function TTY_Supported +-- to test dynamically whether other functions of this package can be called. + +with System; + +with GNAT.OS_Lib; + +package GNAT.TTY is + + type TTY_Handle is private; + -- Handle for a tty descriptor + + function TTY_Supported return Boolean; + -- If True, the other functions of this package can be called. Otherwise, + -- all functions in this package will raise Program_Error if called. + + procedure Allocate_TTY (Handle : out TTY_Handle); + -- Allocate a new tty + + procedure Reset_TTY (Handle : TTY_Handle); + -- Reset settings of a given tty + + procedure Close_TTY (Handle : in out TTY_Handle); + -- Close a given tty + + function TTY_Name (Handle : TTY_Handle) return String; + -- Return the external name of a tty. The name depends on the tty handling + -- on the given target. It will typically look like: "/dev/ptya1" + + function TTY_Descriptor + (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor; + -- Return the low level descriptor associated with Handle + +private + + type TTY_Handle is record + Handle : System.Address := System.Null_Address; + end record; + +end GNAT.TTY; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 4dfc45b6e79..44d75154779 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -1545,10 +1545,10 @@ ada/checks.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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-util.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/par_sco.ads ada/put_alfa.ads ada/restrict.ads ada/restrict.adb \ - ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ - ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/opt.adb \ + ada/output.ads ada/par_sco.ads ada/put_alfa.ads ada/restrict.ads \ + ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \ + ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads ada/sem_ch11.ads \ ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads \ ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads \ @@ -2544,18 +2544,19 @@ ada/exp_smem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ ada/lib-load.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/rtsfind.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_aux.adb 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_prag.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-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-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/uname.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb 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_prag.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-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-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/uname.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/exp_strm.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -2666,21 +2667,22 @@ ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads \ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ ada/lib-load.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads \ - ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \ - ada/sem_ch9.ads ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.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-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \ + ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \ + ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \ + ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinput.ads ada/snames.ads ada/stand.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-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \ @@ -2936,21 +2938,22 @@ ada/inline.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/hostparm.ads ada/inline.ads ada/inline.adb ada/interfac.ads \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_aux.adb 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_prag.ads ada/sem_util.ads ada/sinfo.ads \ - ada/sinfo.adb ada/sinput.ads 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-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/scans.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb 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_prag.ads \ + ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ + 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-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/widechar.ads ada/interfac.o : ada/interfac.ads ada/system.ads @@ -2963,19 +2966,19 @@ ada/itypes.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ ada/itypes.adb ada/lib.ads ada/lib-load.ads ada/namet.ads ada/namet.adb \ ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ - ada/rident.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_prag.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-rident.ads ada/s-secsta.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/restrict.ads ada/rident.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_prag.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-rident.ads \ + ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ + ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/krunch.o : ada/ada.ads ada/a-unccon.ads ada/hostparm.ads \ ada/krunch.ads ada/krunch.adb ada/system.ads ada/s-exctab.ads \ @@ -3689,24 +3692,24 @@ ada/sem.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ ada/lib-sort.adb ada/lib-util.ads ada/lib-xref.ads ada/namet.ads \ ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/opt.ads \ - ada/output.ads ada/put_alfa.ads ada/restrict.ads ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \ - ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads \ - ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch2.ads ada/sem_ch2.adb \ - 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_eval.ads \ - ada/sem_prag.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/stand.ads ada/stringt.ads ada/stylesw.ads \ - ada/system.ads ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb \ - ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \ - ada/warnsw.ads ada/widechar.ads + ada/output.ads ada/put_alfa.ads ada/restrict.ads ada/restrict.adb \ + ada/rident.ads ada/rtsfind.ads ada/scans.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_ch10.ads ada/sem_ch11.ads \ + ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch2.ads \ + ada/sem_ch2.adb 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_eval.ads ada/sem_prag.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/stand.ads ada/stringt.ads \ + ada/stylesw.ads ada/system.ads ada/s-carun8.ads ada/s-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/warnsw.ads ada/widechar.ads ada/sem_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -3812,14 +3815,14 @@ ada/sem_case.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/gnatvsn.ads ada/hlo.ads ada/hostparm.ads ada/inline.ads \ ada/interfac.ads ada/lib.ads ada/lib-load.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/scans.ads ada/sem.ads \ - ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb \ - ada/sem_case.ads ada/sem_case.adb 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_eval.ads ada/sem_prag.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/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \ + ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb ada/sem_case.ads ada/sem_case.adb 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_eval.ads \ + ada/sem_prag.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/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \ ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ @@ -4242,23 +4245,24 @@ ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \ ada/sem.ads ada/sem.adb ada/sem_aggr.ads ada/sem_attr.ads \ ada/sem_aux.ads ada/sem_aux.adb ada/sem_cat.ads ada/sem_ch10.ads \ - ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch2.ads \ - ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \ - ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_ch9.ads \ - ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads ada/sem_elim.ads \ - ada/sem_eval.ads ada/sem_intr.ads ada/sem_prag.ads ada/sem_res.ads \ - ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \ - ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinfo-cn.ads \ - ada/sinput.ads ada/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-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \ - ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch13.adb \ + 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_ch8.adb \ + ada/sem_ch9.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elab.ads \ + ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_prag.ads \ + ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \ + ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb \ + ada/sinfo-cn.ads ada/sinput.ads ada/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-exctab.ads \ + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ + ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/warnsw.ads ada/widechar.ads ada/sem_ch9.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -4345,23 +4349,23 @@ ada/sem_dist.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ ada/lib-load.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/sem.ads ada/sem.adb \ - ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb 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_disp.ads \ - ada/sem_dist.ads ada/sem_dist.adb ada/sem_eval.ads ada/sem_prag.ads \ - ada/sem_res.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/stylesw.ads ada/system.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/types.adb \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \ + ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ + ada/sem_aux.adb 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_disp.ads ada/sem_dist.ads ada/sem_dist.adb \ + ada/sem_eval.ads ada/sem_prag.ads ada/sem_res.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/stylesw.ads ada/system.ads \ + ada/s-carun8.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/types.ads \ + ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/atree.ads \ @@ -4409,22 +4413,23 @@ ada/sem_elim.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ ada/lib.ads ada/lib.adb ada/lib-list.adb ada/lib-load.ads \ ada/lib-sort.adb ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_aux.adb 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_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/stylesw.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-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-strhas.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - 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/nmake.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/scans.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb 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_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/stylesw.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-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-strhas.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads 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/aspects.ads ada/atree.ads \ @@ -4494,21 +4499,22 @@ ada/sem_mech.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/gnat.ads ada/g-htable.ads ada/gnatvsn.ads ada/hlo.ads \ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/lib.ads \ ada/lib-load.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ - ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rident.ads \ - ada/scans.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads ada/sem_aux.ads \ - ada/sem_aux.adb 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_mech.ads ada/sem_mech.adb ada/sem_prag.ads \ - ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ - ada/snames.ads ada/stand.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-rident.ads ada/s-secsta.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/rident.ads ada/scans.ads ada/sem.ads ada/sem.adb \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb 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_mech.ads \ + ada/sem_mech.adb ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.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-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tree_io.ads ada/types.ads \ + ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/ali.ads ada/alloc.ads ada/aspects.ads \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index d000b5df779..ad8917fcd29 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -273,15 +273,9 @@ INCLUDES = -I- -I. -I.. -I$(srcdir)/ada -I$(srcdir) -I$(srcdir)/config \ ADA_INCLUDES = -I- -I. -I$(srcdir)/ada -INCLUDES_FOR_SUBDIR = -iquote . -iquote .. -iquote ../.. -iquote $(fsrcdir)/ada \ - -I$(fsrcdir)/../include - -ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) - # On Windows native the tconfig.h files used by C runtime files needs to have - # the gcc source dir in its include dir list - INCLUDES_FOR_SUBDIR = -iquote . -iquote .. -iquote ../.. -iquote $(fsrcdir)/ada \ - -I$(fsrcdir)/../include -I$(fsrcdir) -endif +INCLUDES_FOR_SUBDIR = -iquote . -iquote .. -iquote ../.. \ + -iquote $(fsrcdir)/ada -iquote $(fsrcdir) \ + -I$(fsrcdir)/../include ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)/ada @@ -1162,6 +1156,7 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),) GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) + MISCLIB = -lutil endif ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(arch) $(osys))),) @@ -1215,6 +1210,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) THREADSLIB= -lpthread GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) + MISCLIB = -lutil endif ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),) @@ -1241,6 +1237,7 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),) THREADSLIB= -lpthread GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) + MISCLIB = -lutil endif ifeq ($(strip $(filter-out s390% linux%,$(arch) $(osys))),) @@ -2182,7 +2179,6 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) EH_MECHANISM=-gcc GNATLIB_SHARED = gnatlib-shared-darwin - RANLIB = ranlib -c GMEM_LIB = gmemlib LIBRARY_VERSION := $(LIB_VERSION) soext = .dylib @@ -2220,12 +2216,13 @@ LIBGNAT_SRCS = adadecode.c adadecode.h adaint.c adaint.h \ argv.c cio.c cstreams.c errno.c exit.c cal.c ctrl_c.c env.c env.h \ arit64.c raise.h raise.c sysdep.c aux-io.c init.c initialize.c \ locales.c seh_init.c final.c tracebak.c tb-alvms.c tb-alvxw.c \ - tb-gcc.c expect.c mkdir.c socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS) + tb-gcc.c expect.c mkdir.c socket.c gsocket.h targext.c \ + terminals.c $(EXTRA_LIBGNAT_SRCS) LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \ errno.o exit.o env.o raise.o sysdep.o aux-io.o init.o initialize.o \ locales.o seh_init.o cal.o arit64.o final.o tracebak.o expect.o \ - mkdir.o socket.o targext.o $(EXTRA_LIBGNAT_OBJS) + mkdir.o socket.o targext.o terminals.o $(EXTRA_LIBGNAT_OBJS) # NOTE ??? - when the -I option for compiling Ada code is made to work, # the library installation will change and there will be a @@ -2866,6 +2863,7 @@ socket.o : socket.c gsocket.h sysdep.o : sysdep.c raise.o : raise.c raise.h sigtramp-ppcvxw.o : sigtramp-ppcvxw.c sigtramp.h +terminals.o : terminals.c vx_stack_info.o : vx_stack_info.c raise-gcc.o : raise-gcc.c raise.h diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index d7ca5dbbe6e..12971a63038 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -160,7 +160,7 @@ static bool compile_time_known_address_p (Node_Id); static bool cannot_be_superflat_p (Node_Id); static bool constructor_address_p (tree); static void components_to_record (tree, Node_Id, tree, int, bool, bool, bool, - bool, bool, bool, bool, tree *); + bool, bool, bool, bool, tree, tree *); static Uint annotate_value (tree); static void annotate_rep (Entity_Id, tree); static tree build_position_list (tree, bool, tree, tree, unsigned int, tree); @@ -176,6 +176,7 @@ static unsigned int ceil_alignment (unsigned HOST_WIDE_INT); static void check_ok_for_atomic (tree, Entity_Id, bool); static tree create_field_decl_from (tree, tree, tree, tree, tree, VEC(subst_pair,heap) *); +static tree create_rep_part (tree, tree, tree); static tree get_rep_part (tree); static tree create_variant_part_from (tree, VEC(variant_desc,heap) *, tree, tree, VEC(subst_pair,heap) *); @@ -3048,7 +3049,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_field_list, packed, definition, false, all_rep, is_unchecked_union, debug_info_p, false, OK_To_Reorder_Components (gnat_entity), - NULL); + all_rep ? NULL_TREE : bitsize_zero_node, NULL); /* If it is passed by reference, force BLKmode to ensure that objects of this type will always be put in memory. */ @@ -7096,6 +7097,10 @@ compare_field_bitpos (const PTR rt1, const PTR rt2) REORDER is true if we are permitted to reorder components of this type. + FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in + the outer record type down to this variant level. It is nonzero only if + all the fields down to this level have a rep clause and ALL_REP is false. + P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field with a rep clause is to be added; in this case, that is all that should be done with such fields. */ @@ -7106,12 +7111,13 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, bool cancel_alignment, bool all_rep, bool unchecked_union, bool debug_info, bool maybe_unused, bool reorder, - tree *p_gnu_rep_list) + tree first_free_pos, tree *p_gnu_rep_list) { bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type); bool layout_with_rep = false; Node_Id component_decl, variant_part; tree gnu_field, gnu_next, gnu_last; + tree gnu_rep_part = NULL_TREE; tree gnu_variant_part = NULL_TREE; tree gnu_rep_list = NULL_TREE; tree gnu_var_list = NULL_TREE; @@ -7185,7 +7191,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))), "XVN"); tree gnu_union_type, gnu_union_name; - tree gnu_variant_list = NULL_TREE; + tree this_first_free_pos, gnu_variant_list = NULL_TREE; if (TREE_CODE (gnu_name) == TYPE_DECL) gnu_name = DECL_NAME (gnu_name); @@ -7193,12 +7199,10 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, gnu_union_name = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name)); - /* Reuse an enclosing union if all fields are in the variant part - and there is no representation clause on the record, to match - the layout of C unions. There is an associated check below. */ - if (!gnu_field_list - && TREE_CODE (gnu_record_type) == UNION_TYPE - && !TYPE_PACKED (gnu_record_type)) + /* Reuse the enclosing union if this is an Unchecked_Union whose fields + are all in the variant part, to match the layout of C unions. There + is an associated check below. */ + if (TREE_CODE (gnu_record_type) == UNION_TYPE) gnu_union_type = gnu_record_type; else { @@ -7210,6 +7214,29 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); } + /* If all the fields down to this level have a rep clause, find out + whether all the fields at this level also have one. If so, then + compute the new first free position to be passed downward. */ + this_first_free_pos = first_free_pos; + if (this_first_free_pos) + { + for (gnu_field = gnu_field_list; + gnu_field; + gnu_field = DECL_CHAIN (gnu_field)) + if (DECL_FIELD_OFFSET (gnu_field)) + { + tree pos = bit_position (gnu_field); + if (!tree_int_cst_lt (pos, this_first_free_pos)) + this_first_free_pos + = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field)); + } + else + { + this_first_free_pos = NULL_TREE; + break; + } + } + for (variant = First_Non_Pragma (Variants (variant_part)); Present (variant); variant = Next_Non_Pragma (variant)) @@ -7231,8 +7258,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); /* Similarly, if the outer record has a size specified and all - fields have record rep clauses, we can propagate the size - into the variant part. */ + the fields have a rep clause, we can propagate the size. */ if (all_rep_and_size) { TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type); @@ -7244,20 +7270,24 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, we aren't sure to really use it at this point, see below. */ components_to_record (gnu_variant_type, Component_List (variant), NULL_TREE, packed, definition, - !all_rep_and_size, all_rep, - unchecked_union, debug_info, - true, reorder, &gnu_rep_list); + !all_rep_and_size, all_rep, unchecked_union, + debug_info, true, reorder, this_first_free_pos, + all_rep || this_first_free_pos + ? NULL : &gnu_rep_list); gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant)); - Set_Present_Expr (variant, annotate_value (gnu_qual)); - /* If this is an Unchecked_Union and we have exactly one field, - use this field directly to match the layout of C unions. */ - if (unchecked_union - && TYPE_FIELDS (gnu_variant_type) - && !DECL_CHAIN (TYPE_FIELDS (gnu_variant_type))) - gnu_field = TYPE_FIELDS (gnu_variant_type); + /* If this is an Unchecked_Union whose fields are all in the variant + part and we have a single field with no representation clause or + placed at offset zero, use the field directly to match the layout + of C unions. */ + if (TREE_CODE (gnu_record_type) == UNION_TYPE + && (gnu_field = TYPE_FIELDS (gnu_variant_type)) != NULL_TREE + && !DECL_CHAIN (gnu_field) + && (!DECL_FIELD_OFFSET (gnu_field) + || integer_zerop (bit_position (gnu_field)))) + DECL_CONTEXT (gnu_field) = gnu_union_type; else { /* Deal with packedness like in gnat_to_gnu_field. */ @@ -7328,15 +7358,18 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, gnu_variant_part = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, all_rep ? TYPE_SIZE (gnu_union_type) : 0, - all_rep ? bitsize_zero_node : 0, + all_rep || this_first_free_pos + ? bitsize_zero_node : 0, union_field_packed, 0); DECL_INTERNAL_P (gnu_variant_part) = 1; - DECL_CHAIN (gnu_variant_part) = gnu_field_list; - gnu_field_list = gnu_variant_part; } } + /* From now on, a zero FIRST_FREE_POS is totally useless. */ + if (first_free_pos && integer_zerop (first_free_pos)) + first_free_pos = NULL_TREE; + /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are permitted to reorder components, self-referential sizes or variable sizes. If they do, pull them out and put them onto the appropriate list. We have @@ -7368,33 +7401,24 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, continue; } - if (reorder) + /* Reorder non-internal fields with non-fixed size. */ + if (reorder + && !DECL_INTERNAL_P (gnu_field) + && !(DECL_SIZE (gnu_field) + && TREE_CODE (DECL_SIZE (gnu_field)) == INTEGER_CST)) { - /* Pull out the variant part and put it onto GNU_SELF_LIST. */ - if (gnu_field == gnu_variant_part) + tree type_size = TYPE_SIZE (TREE_TYPE (gnu_field)); + + if (CONTAINS_PLACEHOLDER_P (type_size)) { MOVE_FROM_FIELD_LIST_TO (gnu_self_list); continue; } - /* Skip internal fields and fields with fixed size. */ - if (!DECL_INTERNAL_P (gnu_field) - && !(DECL_SIZE (gnu_field) - && TREE_CODE (DECL_SIZE (gnu_field)) == INTEGER_CST)) + if (TREE_CODE (type_size) != INTEGER_CST) { - tree type_size = TYPE_SIZE (TREE_TYPE (gnu_field)); - - if (CONTAINS_PLACEHOLDER_P (type_size)) - { - MOVE_FROM_FIELD_LIST_TO (gnu_self_list); - continue; - } - - if (TREE_CODE (type_size) != INTEGER_CST) - { - MOVE_FROM_FIELD_LIST_TO (gnu_var_list); - continue; - } + MOVE_FROM_FIELD_LIST_TO (gnu_var_list); + continue; } } @@ -7416,14 +7440,14 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, = chainon (nreverse (gnu_self_list), chainon (nreverse (gnu_var_list), gnu_field_list)); - /* If we have any fields in our rep'ed field list and it is not the case that - all the fields in the record have rep clauses and P_REP_LIST is nonzero, - set it and ignore these fields. */ - if (gnu_rep_list && p_gnu_rep_list && !all_rep) + /* If P_REP_LIST is nonzero, this means that we are asked to move the fields + in our REP list to the previous level because this level needs them in + order to do a correct layout, i.e. avoid having overlapping fields. */ + if (p_gnu_rep_list && gnu_rep_list) *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list); /* Otherwise, sort the fields by bit position and put them into their own - record, before the others, if we also have fields without rep clauses. */ + record, before the others, if we also have fields without rep clause. */ else if (gnu_rep_list) { tree gnu_rep_type @@ -7451,11 +7475,12 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, if (gnu_field_list) { finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info); - gnu_field - = create_field_decl (get_identifier ("REP"), gnu_rep_type, - gnu_record_type, NULL_TREE, NULL_TREE, 0, 1); - DECL_INTERNAL_P (gnu_field) = 1; - gnu_field_list = chainon (gnu_field_list, gnu_field); + + /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields + without rep clause are laid out starting from this position. + Therefore, we force it as a minimal size on the REP part. */ + gnu_rep_part + = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos); } else { @@ -7464,6 +7489,28 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, } } + /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields without + rep clause are laid out starting from this position. Therefore, if we + have not already done so, we create a fake REP part with this size. */ + if (first_free_pos && !layout_with_rep && !gnu_rep_part) + { + tree gnu_rep_type = make_node (RECORD_TYPE); + finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info); + gnu_rep_part + = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos); + } + + /* Now chain the REP part at the end of the reversed field list. */ + if (gnu_rep_part) + gnu_field_list = chainon (gnu_field_list, gnu_rep_part); + + /* And the variant part at the beginning. */ + if (gnu_variant_part) + { + DECL_CHAIN (gnu_variant_part) = gnu_field_list; + gnu_field_list = gnu_variant_part; + } + if (cancel_alignment) TYPE_ALIGN (gnu_record_type) = 0; @@ -8567,6 +8614,24 @@ create_field_decl_from (tree old_field, tree field_type, tree record_type, return new_field; } +/* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero, + it is the minimal size the REP_PART must have. */ + +static tree +create_rep_part (tree rep_type, tree record_type, tree min_size) +{ + tree field; + + if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size)) + min_size = NULL_TREE; + + field = create_field_decl (get_identifier ("REP"), rep_type, record_type, + min_size, bitsize_zero_node, 0, 1); + DECL_INTERNAL_P (field) = 1; + + return field; +} + /* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */ static tree @@ -8575,10 +8640,10 @@ get_rep_part (tree record_type) tree field = TYPE_FIELDS (record_type); /* The REP part is the first field, internal, another record, and its name - doesn't start with an underscore (i.e. is not generated by the FE). */ + starts with an 'R'. */ if (DECL_INTERNAL_P (field) && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE - && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_') + && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R') return field; return NULL_TREE; diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 8a74e6ccb45..42b4e9154c3 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -129,6 +129,7 @@ struct GTY(()) language_function { VEC(parm_attr,gc) *parm_attr_cache; bitmap named_ret_val; VEC(tree,gc) *other_ret_val; + int gnat_ret; }; #define f_parm_attr_cache \ @@ -140,6 +141,9 @@ struct GTY(()) language_function { #define f_other_ret_val \ DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val +#define f_gnat_ret \ + DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret + /* A structure used to gather together information about a statement group. We use this to gather related statements, for example the "then" part of a IF. In the case where it represents a lexical scope, we may also @@ -2674,12 +2678,20 @@ establish_gnat_vms_condition_handler (void) first list. These are the Named Return Values. 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the - Named Return Values in the function with the RESULT_DECL. */ + Named Return Values in the function with the RESULT_DECL. + + If the function returns an unconstrained type, things are a bit different + because the anonymous return object is allocated on the secondary stack + and RESULT_DECL is only a pointer to it. Each return object can be of a + different size and is allocated separately so we need not care about the + aforementioned overlapping issues. Therefore, we don't collect the other + expressions and skip step #2 in the algorithm. */ struct nrv_data { bitmap nrv; tree result; + Node_Id gnat_ret; struct pointer_set_t *visited; }; @@ -2812,8 +2824,153 @@ finalize_nrv_r (tree *tp, int *walk_subtrees, void *data) *tp = convert (TREE_TYPE (t), dp->result); /* Avoid walking into the same tree more than once. Unfortunately, we - can't just use walk_tree_without_duplicates because it would only call - us for the first occurrence of NRVs in the function body. */ + can't just use walk_tree_without_duplicates because it would only + call us for the first occurrence of NRVs in the function body. */ + if (pointer_set_insert (dp->visited, *tp)) + *walk_subtrees = 0; + + return NULL_TREE; +} + +/* Likewise, but used when the function returns an unconstrained type. */ + +static tree +finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) +{ + struct nrv_data *dp = (struct nrv_data *)data; + tree t = *tp; + + /* No need to walk into types. */ + if (TYPE_P (t)) + *walk_subtrees = 0; + + /* We need to see the DECL_EXPR of NRVs before any other references so we + walk the body of BIND_EXPR before walking its variables. */ + else if (TREE_CODE (t) == BIND_EXPR) + walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL); + + /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final + return value built by the allocator instead of the whole construct. */ + else if (TREE_CODE (t) == RETURN_EXPR + && TREE_CODE (TREE_OPERAND (t, 0)) == MODIFY_EXPR) + { + tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1); + + /* This is the construct returned by the allocator. */ + if (TREE_CODE (ret_val) == COMPOUND_EXPR + && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR) + { + if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val))) + ret_val + = VEC_index (constructor_elt, + CONSTRUCTOR_ELTS + (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1)), + 1)->value; + else + ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1); + } + + /* Strip useless conversions around the return value. */ + if (gnat_useless_type_conversion (ret_val) + || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR) + ret_val = TREE_OPERAND (ret_val, 0); + + /* Strip unpadding around the return value. */ + if (TREE_CODE (ret_val) == COMPONENT_REF + && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0)))) + ret_val = TREE_OPERAND (ret_val, 0); + + /* Assign the new return value to the RESULT_DECL. */ + if (is_nrv_p (dp->nrv, ret_val)) + TREE_OPERAND (TREE_OPERAND (t, 0), 1) + = TREE_OPERAND (DECL_INITIAL (ret_val), 0); + } + + /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result + into a new variable. */ + else if (TREE_CODE (t) == DECL_EXPR + && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t))) + { + tree saved_current_function_decl = current_function_decl; + tree var = DECL_EXPR_DECL (t); + tree alloc, p_array, new_var, new_ret; + VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 2); + + /* Create an artificial context to build the allocation. */ + current_function_decl = decl_function_context (var); + start_stmt_group (); + gnat_pushlevel (); + + /* This will return a COMPOUND_EXPR with the allocation in the first + arm and the final return value in the second arm. */ + alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var), + TREE_TYPE (dp->result), + Procedure_To_Call (dp->gnat_ret), + Storage_Pool (dp->gnat_ret), + Empty, false); + + /* The new variable is built as a reference to the allocated space. */ + new_var + = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var), + build_reference_type (TREE_TYPE (var))); + DECL_BY_REFERENCE (new_var) = 1; + + if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc))) + { + /* The new initial value is a COMPOUND_EXPR with the allocation in + the first arm and the value of P_ARRAY in the second arm. */ + DECL_INITIAL (new_var) + = build2 (COMPOUND_EXPR, TREE_TYPE (new_var), + TREE_OPERAND (alloc, 0), + VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)), + 0)->value); + + /* Build a modified CONSTRUCTOR that references NEW_VAR. */ + p_array = TYPE_FIELDS (TREE_TYPE (alloc)); + CONSTRUCTOR_APPEND_ELT (v, p_array, + fold_convert (TREE_TYPE (p_array), new_var)); + CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array), + VEC_index (constructor_elt, + CONSTRUCTOR_ELTS + (TREE_OPERAND (alloc, 1)), + 1)->value); + new_ret = build_constructor (TREE_TYPE (alloc), v); + } + else + { + /* The new initial value is just the allocation. */ + DECL_INITIAL (new_var) = alloc; + new_ret = fold_convert (TREE_TYPE (alloc), new_var); + } + + gnat_pushdecl (new_var, Empty); + + /* Destroy the artificial context and insert the new statements. */ + gnat_zaplevel (); + *tp = end_stmt_group (); + current_function_decl = saved_current_function_decl; + + /* Chain NEW_VAR immediately after VAR and ignore the latter. */ + DECL_CHAIN (new_var) = DECL_CHAIN (var); + DECL_CHAIN (var) = new_var; + DECL_IGNORED_P (var) = 1; + + /* Save the new return value and the dereference of NEW_VAR. */ + DECL_INITIAL (var) + = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret, + build1 (INDIRECT_REF, TREE_TYPE (var), new_var)); + /* ??? Kludge to avoid messing up during inlining. */ + DECL_CONTEXT (var) = NULL_TREE; + } + + /* And replace all uses of NRVs with the dereference of NEW_VAR. */ + else if (is_nrv_p (dp->nrv, t)) + *tp = TREE_OPERAND (DECL_INITIAL (t), 1); + + /* Avoid walking into the same tree more than once. Unfortunately, we + can't just use walk_tree_without_duplicates because it would only + call us for the first occurrence of NRVs in the function body. */ if (pointer_set_insert (dp->visited, *tp)) *walk_subtrees = 0; @@ -2822,13 +2979,14 @@ finalize_nrv_r (tree *tp, int *walk_subtrees, void *data) /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap contains the candidates for Named Return Value and OTHER is a list of - the other return values. */ + the other return values. GNAT_RET is a representative return node. */ static void -finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other) +finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other, Node_Id gnat_ret) { struct cgraph_node *node; struct nrv_data data; + walk_tree_fn func; unsigned int i; tree iter; @@ -2860,8 +3018,13 @@ finalize_nrv (tree fndecl, bitmap nrv, VEC(tree,gc) *other) /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */ data.nrv = nrv; data.result = DECL_RESULT (fndecl); + data.gnat_ret = gnat_ret; data.visited = pointer_set_create (); - walk_tree (&DECL_SAVED_TREE (fndecl), finalize_nrv_r, &data, NULL); + if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl))) + func = finalize_nrv_unc_r; + else + func = finalize_nrv_r; + walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL); pointer_set_destroy (data.visited); } @@ -2886,7 +3049,7 @@ return_value_ok_for_nrv_p (tree ret_obj, tree ret_val) if (TREE_ADDRESSABLE (ret_val)) return false; - if (DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj)) + if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj)) return false; return true; @@ -3278,6 +3441,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) save_gnu_tree (gnat_param, NULL_TREE, false); } + /* Disconnect the variable created for the return value. */ if (gnu_return_var_elmt) TREE_VALUE (gnu_return_var_elmt) = void_type_node; @@ -3285,8 +3449,10 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) a Named Return Value, finalize the optimization. */ if (optimize && gnu_subprog_language->named_ret_val) { - finalize_nrv (gnu_subprog_decl, gnu_subprog_language->named_ret_val, - gnu_subprog_language->other_ret_val); + finalize_nrv (gnu_subprog_decl, + gnu_subprog_language->named_ret_val, + gnu_subprog_language->other_ret_val, + gnu_subprog_language->gnat_ret); gnu_subprog_language->named_ret_val = NULL; gnu_subprog_language->other_ret_val = NULL; } @@ -5881,6 +6047,34 @@ gnat_to_gnu (Node_Id gnat_node) else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)) { gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); + + /* And find out whether this is a candidate for Named Return + Value. If so, record it. */ + if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize) + { + tree ret_val = gnu_ret_val; + + /* Strip useless conversions around the return value. */ + if (gnat_useless_type_conversion (ret_val)) + ret_val = TREE_OPERAND (ret_val, 0); + + /* Strip unpadding around the return value. */ + if (TREE_CODE (ret_val) == COMPONENT_REF + && TYPE_IS_PADDING_P + (TREE_TYPE (TREE_OPERAND (ret_val, 0)))) + ret_val = TREE_OPERAND (ret_val, 0); + + /* Now apply the test to the return value. */ + if (return_value_ok_for_nrv_p (NULL_TREE, ret_val)) + { + if (!f_named_ret_val) + f_named_ret_val = BITMAP_GGC_ALLOC (); + bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val)); + if (!f_gnat_ret) + f_gnat_ret = gnat_node; + } + } + gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val, TREE_TYPE (gnu_ret_obj), @@ -5889,12 +6083,12 @@ gnat_to_gnu (Node_Id gnat_node) gnat_node, false); } - /* If the function returns by invisible reference, dereference + /* Otherwise, if it returns by invisible reference, dereference the pointer it is passed using the type of the return value and build the copy operation manually. This ensures that we don't copy too much data, for example if the return type is unconstrained with a maximum size. */ - if (TREE_ADDRESSABLE (gnu_subprog_type)) + else if (TREE_ADDRESSABLE (gnu_subprog_type)) { tree gnu_ret_deref = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val), @@ -5905,11 +6099,9 @@ gnat_to_gnu (Node_Id gnat_node) gnu_ret_val = NULL_TREE; } } + else - { - gnu_ret_obj = NULL_TREE; - gnu_ret_val = NULL_TREE; - } + gnu_ret_obj = gnu_ret_val = NULL_TREE; /* If we have a return label defined, convert this into a branch to that label. The return proper will be handled elsewhere. */ @@ -5934,8 +6126,8 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Goto_Statement: - gnu_result = build1 (GOTO_EXPR, void_type_node, - gnat_to_gnu (Name (gnat_node))); + gnu_result + = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node))); break; /***************************/ diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 73657528a8a..a71a3d28878 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -4744,19 +4744,17 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) enum tree_code tree_code_for_record_type (Entity_Id gnat_type) { - Node_Id component_list - = Component_List (Type_Definition - (Declaration_Node - (Implementation_Base_Type (gnat_type)))); - Node_Id component; - - /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or - we have a non-discriminant field outside a variant. In either case, - it's a RECORD_TYPE. */ + Node_Id component_list, component; + /* Return UNION_TYPE if it's an Unchecked_Union whose non-discriminant + fields are all in the variant part. Otherwise, return RECORD_TYPE. */ if (!Is_Unchecked_Union (gnat_type)) return RECORD_TYPE; + gnat_type = Implementation_Base_Type (gnat_type); + component_list + = Component_List (Type_Definition (Declaration_Node (gnat_type))); + for (component = First_Non_Pragma (Component_Items (component_list)); Present (component); component = Next_Non_Pragma (component)) diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index c303e2f20a3..f9e48b79fe5 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -2126,7 +2126,7 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) return build2 (COMPOUND_EXPR, TREE_TYPE (aligning_field_addr), - build_binary_op (MODIFY_EXPR, NULL_TREE, + build_binary_op (INIT_EXPR, NULL_TREE, storage_ptr_slot, storage_ptr), aligning_field_addr); } @@ -2279,12 +2279,12 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (storage_type)), init); storage_init - = build_binary_op (MODIFY_EXPR, NULL_TREE, storage_deref, + = build_binary_op (INIT_EXPR, NULL_TREE, storage_deref, gnat_build_constructor (storage_type, v)); } else storage_init - = build_binary_op (MODIFY_EXPR, NULL_TREE, + = build_binary_op (INIT_EXPR, NULL_TREE, build_component_ref (storage_deref, NULL_TREE, TYPE_FIELDS (storage_type), false), @@ -2332,7 +2332,7 @@ build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, storage_deref = build_unary_op (INDIRECT_REF, NULL_TREE, storage); TREE_THIS_NOTRAP (storage_deref) = 1; storage_init - = build_binary_op (MODIFY_EXPR, NULL_TREE, storage_deref, init); + = build_binary_op (INIT_EXPR, NULL_TREE, storage_deref, init); return build2 (COMPOUND_EXPR, result_type, storage_init, storage); } diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 2d342c347bc..8a51161a8fa 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -374,6 +374,7 @@ The GNAT Library * GNAT.Exception_Traces (g-exctra.ads):: * GNAT.Exceptions (g-except.ads):: * GNAT.Expect (g-expect.ads):: +* GNAT.Expect.TTY (g-exptty.ads):: * GNAT.Float_Control (g-flocon.ads):: * GNAT.Heap_Sort (g-heasor.ads):: * GNAT.Heap_Sort_A (g-hesora.ads):: @@ -6372,12 +6373,11 @@ refer to the value of the prefix on entry. So for example if you have an argument of a record type X called Arg1, you can refer to Arg1.Field'Old which yields the value of Arg1.Field on entry. The implementation simply involves generating -an object declaration which captures the value on entry. Any -prefix is allowed except one of a limited type (since limited -types cannot be copied to capture their values) or an expression -which references a local variable -(since local variables do not exist at subprogram entry time). - +an object declaration which captures the value on entry. +The prefix must denote an object of a nonlimited type (since limited types +cannot be copied to capture their values) and it must not reference a local +variable (since local variables do not exist at subprogram entry time). Note +that the variable introduced by a quantified expression is a local variable. The following example shows the use of 'Old to implement a test of a postcondition: @@ -9633,7 +9633,8 @@ separate section on Intrinsic Subprograms. @item Stdcall Stdcall (used for Windows implementations only). This convention correspond to the WINAPI (previously called Pascal convention) C/C++ convention under -Windows. A function with this convention cleans the stack before exit. +Windows. A routine with this convention cleans the stack before +exit. This pragma cannot be applied to a dispatching call. @item DLL Synonym for Stdcall @item Win32 @@ -14187,6 +14188,7 @@ of GNAT, and will generate a warning message. * GNAT.Exception_Traces (g-exctra.ads):: * GNAT.Exceptions (g-except.ads):: * GNAT.Expect (g-expect.ads):: +* GNAT.Expect.TTY (g-exptty.ads):: * GNAT.Float_Control (g-flocon.ads):: * GNAT.Heap_Sort (g-heasor.ads):: * GNAT.Heap_Sort_A (g-hesora.ads):: @@ -15054,6 +15056,16 @@ is implemented on all native GNAT ports except for OpenVMS@. It is not implemented for cross ports, and in particular is not implemented for VxWorks or LynxOS@. +@node GNAT.Expect.TTY (g-exptty.ads) +@section @code{GNAT.Expect.TTY} (@file{g-exptty.ads}) +@cindex @code{GNAT.Expect.TTY} (@file{g-exptty.ads}) + +@noindent +As GNAT.Expect but using pseudo-terminal. +Currently @code{GNAT.Expect.TTY} is implemented on all native GNAT +ports except for OpenVMS@. It is not implemented for cross ports, and +in particular is not implemented for VxWorks or LynxOS@. + @node GNAT.Float_Control (g-flocon.ads) @section @code{GNAT.Float_Control} (@file{g-flocon.ads}) @cindex @code{GNAT.Float_Control} (@file{g-flocon.ads}) diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 253cfff172b..ba5737a487e 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -11805,7 +11805,7 @@ recognized by GNAT: @section Handling of Configuration Pragmas Configuration pragmas may either appear at the start of a compilation -unit, in which case they apply only to that unit, or they may apply to +unit, or they can appear in a configuration pragma file to apply to all compilations performed in a given compilation environment. GNAT also provides the @code{gnatchop} utility to provide an automatic @@ -11816,6 +11816,30 @@ However, for most purposes, it will be more convenient to edit the @file{gnat.adc} file that contains configuration pragmas directly, as described in the following section. +In the case of @code{Restrictions} pragmas appearing as configuration +pragmas in individual compilation units, the exact handling depends on +the type of restriction. + +Restrictions that require partition-wide consistency (like +@code{No_Tasking}) are +recognized wherever they appear +and can be freely inherited, e.g. from a with'ed unit to the with'ing +unit. This makes sense since the binder will in any case insist on seeing +consistent use, so any unit not conforming to any restrictions that are +anywhere in the partition will be rejected, and you might as well find +that out at compile time rather than at bind time. + +For restrictions that do not require partition-wide consistency, e.g. +SPARK or No_Implementation_Attributes, in general the restriction applies +only to the unit in which the pragma appears, and not to any other units. + +The exception is No_Elaboration_Code which always applies to the entire +object file from a compilation, i.e. to the body, spec, and all subunits. +This restriction can be specified in a configuration pragma file, or it +can be on the body and/or the spec (in eithe case it applies to all the +relevant units). It can appear on a subunit only if it has previously +appeared in the body of spec. + @node The Configuration Pragmas Files @section The Configuration Pragmas Files @cindex @file{gnat.adc} @@ -13164,6 +13188,23 @@ setting. Enumeration literals are in mixed case. Overrides ^-n^/NAME_CASING^ casing setting. +@cindex @option{^-nt@var{x}^/TYPE_CASING^} (@command{gnatpp}) +@item ^-neD^/TYPE_CASING=AS_DECLARED^ +Type and subtype name casing for defining occurrences are as they appear in +the source file. Overrides ^-n^/NAME_CASING^ casing setting. + +@item ^-ntU^/TYPE_CASING=UPPER_CASE^ +Type and subtype names are in upper case. Overrides ^-n^/NAME_CASING^ casing +setting. + +@item ^-ntL^/TYPE_CASING=LOWER_CASE^ +Type and subtype names are in lower case. Overrides ^-n^/NAME_CASING^ casing +setting. + +@item ^-ntM^/TYPE_CASING=MIXED_CASE^ +Type and subtype names are in mixed case. Overrides ^-n^/NAME_CASING^ casing +setting. + @cindex @option{^-p@var{x}^/PRAGMA_CASING^} (@command{gnatpp}) @item ^-pL^/PRAGMA_CASING=LOWER_CASE^ Pragma names are lower case @@ -13364,6 +13405,19 @@ and variants if there are @var{nnn} or more (the default value is 10). If @var{nnn} is 0, an additional indentation level is used for @b{case} alternatives and variants regardless of their number. + +@item ^--call_threshold=@var{nnn}^/MAX_ACT=@var{nnn}^ +@cindex @option{^--call_threshold^/MAX_ACT^} (@command{gnatpp}) +If the number of parameter associations is greater than @var{nnn} and if at +least one association uses named notation, start each association from +a new line. If @var{nnn} is 0, no check for the number of associations +is made, this is the default. + +@item ^--par_threshold=@var{nnn}^/MAX_PAR=@var{nnn}^ +@cindex @option{^--par_threshold^/MAX_PAR^} (@command{gnatpp}) +If the number of parameter specifications is greater than @var{nnn} +(or equal to @var{nnn} in case of a function), start each specification from +a new line. The default for @var{nnn} is 3. @end table @node Setting the Source Search Path @@ -17889,6 +17943,9 @@ gnatmake -P<harness-dir>/test_driver test_runner @end smallexample +Note that you might need to specify the necessary values of scenario variables +when you are not using the AUnit defaults. + @item actual unit test stubs a test stub for each visible subprogram is created in a separate file, if it doesn't exist already. By default, those separate test files are located in a @@ -17899,6 +17956,9 @@ file my_unit.ads in directory src contains a visible subprogram Proc, then the corresponding unit test will be found in file src/tests/my_unit-tests-proc_<code>.adb. <code> is a signature encoding used to differentiate test names in cases of overloading. + +Note that if the project already has both my_unit.ads and my_unit-tests.ads this +will cause name a conflict with generated test package. @end itemize @node Switches for gnattest @@ -17921,6 +17981,10 @@ manual tests to be added to the test suite. @cindex @option{-r} (@command{gnattest}) Recursively consider all sources from all projects. +@item -X@var{name=value} +@cindex @option{-X} (@command{gnattest}) +Indicate that external variable @var{name} has the value @var{value}. + @item -q @cindex @option{-q} (@command{gnattest}) Suppresses noncritical output messages. @@ -18311,6 +18375,8 @@ The tool currently does not support following features: @item generic tests for generic packages and package instantiations @item tests for protected subprograms and entries @item aspects Precondition, Postcondition, and Test_Case +@item generating test packages for code that is not conformant with ada 2005 + @end itemize @c ********************************* diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 63ab9256953..496f6ce50d4 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -270,6 +270,7 @@ package body Impunit is ("g-except", F), -- GNAT.Exceptions ("g-exctra", F), -- GNAT.Exception_Traces ("g-expect", F), -- GNAT.Expect + ("g-exptty", F), -- GNAT.Expect.TTY ("g-flocon", F), -- GNAT.Float_Control ("g-heasor", F), -- GNAT.Heap_Sort ("g-hesora", F), -- GNAT.Heap_Sort_A @@ -318,6 +319,7 @@ package body Impunit is ("g-timsta", F), -- GNAT.Time_Stamp ("g-traceb", F), -- GNAT.Traceback ("g-trasym", F), -- GNAT.Traceback.Symbolic + ("g-tty ", F), -- GNAT.TTY ("g-utf_32", F), -- GNAT.UTF_32 ("g-u3spch", F), -- GNAT.UTF_32_Spelling_Checker ("g-wispch", F), -- GNAT.Wide_Spelling_Checker diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 8d2f4e1f235..cc6c1d2c50b 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1808,8 +1808,8 @@ __gnat_error_handler (int sig, break; case SIGBUS: - exception = &constraint_error; - msg = "SIGBUS"; + exception = &storage_error; + msg = "SIGBUS: possible stack overflow"; break; default: @@ -2282,11 +2282,12 @@ __gnat_is_stack_guard (mach_vm_address_t addr) return 0; } -static void -__gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) +#define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE + +void +__gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) { - struct Exception_Data *exception; - const char *msg; #if defined (__x86_64__) /* Work around radar #10302855/pr50678, where the unwinders (libunwind or libgcc_s depending on the system revision) and the DWARF unwind data for @@ -2294,9 +2295,19 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED) and rdx to be transposed).. */ ucontext_t *uc = (ucontext_t *)ucontext ; unsigned long t = uc->uc_mcontext->__ss.__rbx; + uc->uc_mcontext->__ss.__rbx = uc->uc_mcontext->__ss.__rdx; uc->uc_mcontext->__ss.__rdx = t; #endif +} + +static void +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext) +{ + struct Exception_Data *exception; + const char *msg; + + __gnat_adjust_context_for_raise (sig, ucontext); switch (sig) { diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index bb8aa113211..519fad0f357 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -3088,7 +3088,7 @@ package body Layout is end if; -- Here we calculate the alignment as the largest power of two multiple - -- of System.Storage_Unit that does not exceed either the actual size of + -- of System.Storage_Unit that does not exceed either the object size of -- the type, or the maximum allowed alignment. declare @@ -3126,21 +3126,101 @@ package body Layout is A := 2 * A; end loop; - -- Now we think we should set the alignment to A, but we skip this if - -- an alignment is already set to a value greater than A (happens for - -- derived types). + -- If alignment is currently not set, then we can safetly set it to + -- this new calculated value. - -- However, if the alignment is known and too small it must be - -- increased, this happens in a case like: + if Unknown_Alignment (E) then + Init_Alignment (E, A); + + -- Cases where we have inherited an alignment + + -- For constructed types, always reset the alignment, these are + -- Generally invisible to the user anyway, and that way we are + -- sure that no constructed types have weird alignments. + + elsif not Comes_From_Source (E) then + Init_Alignment (E, A); + + -- If this inherited alignment is the same as the one we computed, + -- then obviously everything is fine, and we do not need to reset it. - -- type R is new Character; - -- for R'Size use 16; + elsif Alignment (E) = A then + null; - -- Here the alignment inherited from Character is 1, but it must be - -- increased to 2 to reflect the increased size. + -- Now we come to the difficult cases where we have inherited an + -- alignment and size, but overridden the size but not the alignment. + + elsif Has_Size_Clause (E) or else Has_Object_Size_Clause (E) then + + -- This is tricky, it might be thought that we should try to + -- inherit the alignment, since that's what the RM implies, but + -- that leads to complex rules and oddities. Consider for example: + + -- type R is new Character; + -- for R'Size use 16; + + -- It seems quite bogus in this case to inherit an alignment of 1 + -- from the parent type Character. Furthermore, if that's what the + -- programmer really wanted for some odd reason, then they could + -- specify the alignment they wanted. + + -- Furthermore we really don't want to inherit the alignment in + -- the case of a specified Object_Size for a subtype, since then + -- there would be no way of overriding to give a reasonable value + -- (we don't have an Object_Subtype attribute). Consider: + + -- subtype R is new Character; + -- for R'Object_Size use 16; + + -- If we inherit the alignment of 1, then we have an odd + -- inefficient alignment for the subtype, which cannot be fixed. + + -- So we make the decision that if Size (or Object_Size) is given + -- (and, in the case of a first subtype, the alignment is not set + -- with a specific alignment clause). We reset the alignment to + -- the appropriate value for the specified size. This is a nice + -- simple rule to implement and document. + + -- There is one slight glitch, which is that a confirming size + -- clause can now change the alignment, which, if we really think + -- that confirming rep clauses should have no effect, is a no-no. + + -- type R is new Character; + -- for R'Alignment use 2; + -- type S is new R; + -- for S'Size use Character'Size; + + -- Now the alignment of S is 1 instead of 2, as a result of + -- applying the above rule to the confirming rep clause for S. Not + -- clear this is worth worrying about. If we recorded whether a + -- size clause was confirming we could avoid this, but right now + -- we have no way of doing that or easily figuring it out, so we + -- don't bother. + + -- Historical note. In versions of GNAT prior to Nov 6th, 2010, an + -- odd distinction was made between inherited alignments greater + -- than the computed alignment (where the larger alignment was + -- inherited) and inherited alignments smaller than the computed + -- alignment (where the smaller alignment was overridden). This + -- was a dubious fix to get around an ACATS problem which seems + -- to have disappeared anyway, and in any case, this peculiarity + -- was never documented. - if Unknown_Alignment (E) or else Alignment (E) < A then Init_Alignment (E, A); + + -- If no Size (or Object_Size) was specified, then we inherited the + -- object size, so we should inherit the alignment as well and not + -- modify it. This takes care of cases like: + + -- type R is new Integer; + -- for R'Alignment use 1; + -- subtype S is R; + + -- Here we have R has a default Object_Size of 32, and a specified + -- alignment of 1, and it seeems right for S to inherit both values. + + else + null; end if; end; end Set_Elem_Alignment; diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 894c76017d9..0ac729ece6c 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -359,9 +359,25 @@ package body Lib.Load is Src_Ind : Source_File_Index; Save_PMES : constant Boolean := Parsing_Main_Extended_Source; + Save_Cunit_Restrictions : constant Save_Cunit_Boolean_Restrictions := + Cunit_Boolean_Restrictions_Save; + -- Save current restrictions for restore at end + begin Parsing_Main_Extended_Source := PMES; + -- Initialize restrictions to config restrictions for unit to load if + -- it is part of the main extended source, otherwise reset them. + + -- Note: it's a bit odd but PMES is False for subunits, which is why + -- we have the OR here. Should be investigated some time??? + + if PMES or Subunit then + Restore_Config_Cunit_Boolean_Restrictions; + else + Reset_Cunit_Boolean_Restrictions; + end if; + -- If renamings are allowed and we have a child unit name, then we -- must first load the parent to deal with finding the real name. -- Retain the with_clause that names the child, so that if it is @@ -782,6 +798,7 @@ package body Lib.Load is <<Done>> Parsing_Main_Extended_Source := Save_PMES; + Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions); return Unum; end Load_Unit; diff --git a/gcc/ada/lib-load.ads b/gcc/ada/lib-load.ads index d2856aa41f2..a029d3793b0 100644 --- a/gcc/ada/lib-load.ads +++ b/gcc/ada/lib-load.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -155,6 +155,7 @@ package Lib.Load is -- -- PMES indicates the required setting of Parsing_Main_Extended_Unit during -- loading of the unit. This flag is saved and restored over the call. + -- Note: PMES is false for the subunit case, which seems wrong??? procedure Change_Main_Unit_To_Spec; -- This procedure is called if the main unit file contains a No_Body pragma diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 83a06e452f3..0e8337f70c6 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -577,14 +577,16 @@ package body Lib.Xref is -- doing in such cases. For example the calls in Ada.Characters.Handling -- to its own obsolescent subprograms are just fine. - -- In any case we do not generate warnings within the extended source - -- unit of the entity in question, since we assume the source unit - -- itself knows what is going on (and for sure we do not want silly - -- warnings, e.g. on the end line of an obsolescent procedure body). + -- In any case we only generate warnings if we are in the extended main + -- source unit, and the entity itself is not in the extended main source + -- unit, since we assume the source unit itself knows what is going on + -- (and for sure we do not want silly warnings, e.g. on the end line of + -- an obsolescent procedure body). if Is_Obsolescent (E) and then not GNAT_Mode and then not In_Extended_Main_Source_Unit (E) + and then In_Extended_Main_Source_Unit (N) then Check_Restriction (No_Obsolescent_Features, N); diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 76810c22862..2b3f90650cd 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -518,7 +518,7 @@ package Lib is -- its subunits (considered recursively). Units for which this enquiry -- returns True are those for which code will be generated. Nodes from -- instantiations are included in the extended main unit for this call. - -- If the main unit is itself a subunit, then the extended main unit + -- If the main unit is itself a subunit, then the extended main code unit -- includes its parent unit, and the parent unit spec if it is separate. function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean; @@ -533,7 +533,7 @@ package Lib is -- returns True are those for which code will be generated. This differs -- from In_Extended_Main_Code_Unit only in that instantiations are not -- included for the purposes of this call. If the main unit is itself - -- a subunit, then the extended main unit includes its parent unit, + -- a subunit, then the extended main source unit includes its parent unit, -- and the parent unit spec if it is separate. function In_Extended_Main_Source_Unit (Loc : Source_Ptr) return Boolean; diff --git a/gcc/ada/mlib-tgt-specific-darwin.adb b/gcc/ada/mlib-tgt-specific-darwin.adb index e04225370eb..13beb04a8bf 100644 --- a/gcc/ada/mlib-tgt-specific-darwin.adb +++ b/gcc/ada/mlib-tgt-specific-darwin.adb @@ -36,8 +36,6 @@ package body MLib.Tgt.Specific is -- Non default subprograms - function Archive_Indexer_Options return String_List_Access; - procedure Build_Dynamic_Library (Ofiles : Argument_List; Options : Argument_List; @@ -62,15 +60,6 @@ package body MLib.Tgt.Specific is Shared_Options : constant Argument_List := (1 => Shared_Libgcc'Access); - ----------------------------- - -- Archive_Indexer_Options -- - ----------------------------- - - function Archive_Indexer_Options return String_List_Access is - begin - return new String_List'(1 => new String'("-c")); - end Archive_Indexer_Options; - --------------------------- -- Build_Dynamic_Library -- --------------------------- @@ -175,7 +164,6 @@ package body MLib.Tgt.Specific is end Is_Archive_Ext; begin - Archive_Indexer_Options_Ptr := Archive_Indexer_Options'Access; Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; DLL_Ext_Ptr := DLL_Ext'Access; Dynamic_Option_Ptr := Dynamic_Option'Access; diff --git a/gcc/ada/mlib-tgt-specific-vxworks.adb b/gcc/ada/mlib-tgt-specific-vxworks.adb index 1e1fad1d777..17a9d74a17f 100644 --- a/gcc/ada/mlib-tgt-specific-vxworks.adb +++ b/gcc/ada/mlib-tgt-specific-vxworks.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,9 +132,9 @@ package body MLib.Tgt.Specific is return ""; end Dynamic_Option; - ----------------------------- + ----------------------- -- Get_Target_Suffix -- - ----------------------------- + ----------------------- function Get_Target_Suffix return String is Target_Name : constant String := Sdefault.Target_Name.all; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index e6a42815e82..4c1f5609318 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -140,7 +140,7 @@ package Opt is -- or internal units, so it reflects the Ada version explicitly set -- using configuration pragmas or compiler switches (or if neither -- appears, it remains set to Ada_Version_Default). This is used in - -- the rare cases (notably for pragmas Preelaborate_05 and Pure_05) + -- the rare cases (notably for pragmas Preelaborate_05 and Pure_05/12) -- where in the run-time we want the explicit version set. Ada_Version_Runtime : Ada_Version_Type := Ada_2012; @@ -1830,6 +1830,9 @@ package Opt is -- this flag, see package Expander. Indeed this flag might more logically -- be in the spec of Expander, but it is referenced by Errout, and it -- really seems wrong for Errout to depend on Expander. + -- + -- Note: for many purposes, it is more appropriate to test the flag + -- Full_Expander_Active, which also checks that Alfa mode is not active. Static_Dispatch_Tables : Boolean := True; -- This flag indicates if the backend supports generation of statically diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 85b4024df8c..59884d24c73 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -2553,6 +2553,11 @@ package body Ch4 is Node1 : Node_Id; begin + if Ada_Version < Ada_2012 then + Error_Msg_SC ("quantified expression is an Ada 2012 feature"); + Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch"); + end if; + Scan; -- past FOR Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr); diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 7d598547911..36691f34d28 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -108,7 +108,8 @@ package body Ch6 is -- end [DESIGNATOR]; -- SUBPROGRAM_RENAMING_DECLARATION ::= - -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; + -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME + -- [ASPECT_SPECIFICATIONS]; -- SUBPROGRAM_BODY_STUB ::= -- SUBPROGRAM_SPECIFICATION is separate; @@ -506,6 +507,7 @@ package body Ch6 is Scan; -- past RENAMES Set_Name (Rename_Node, P_Name); Set_Specification (Rename_Node, Specification_Node); + P_Aspect_Specifications (Rename_Node); TF_Semicolon; Pop_Scope_Stack; return Rename_Node; @@ -1679,7 +1681,7 @@ package body Ch6 is if Ada_Version < Ada_2012 then Error_Msg_SC -- CODEFIX - ("ALIASED not allowed in extended return in Ada2012?"); + ("ALIASED not allowed in extended return in Ada 2012?"); else Error_Msg_SC -- CODEFIX ("ALIASED not allowed in extended return"); diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 224b992274e..1a126759f6b 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1216,6 +1216,7 @@ begin Pragma_Psect_Object | Pragma_Pure | Pragma_Pure_05 | + Pragma_Pure_12 | Pragma_Pure_Function | Pragma_Queuing_Policy | Pragma_Relative_Deadline | diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 259cfb8e789..f281c7964f0 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -174,7 +174,7 @@ package body Util is procedure Check_Future_Keyword is begin - -- Ada 2005 (AI-284): Compiling in Ada95 mode we warn that INTERFACE, + -- Ada 2005 (AI-284): Compiling in Ada 95 mode we warn that INTERFACE, -- OVERRIDING, and SYNCHRONIZED are new reserved words. if Ada_Version = Ada_95 diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 022efe3c80b..23ad841a3c5 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -99,12 +99,15 @@ package body Prj.Part is package Virtual_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Node_Id, - No_Element => Empty_Node, + No_Element => Project_Node_High_Bound, Key => Project_Node_Id, Hash => Prj.Tree.Hash, Equal => "="); - -- Hash table to store the node id of the project for which a virtual - -- extending project need to be created. + -- Hash table to store the node ids of projects for which a virtual + -- extending project need to be created. The corresponding value is the + -- head of a list of WITH clauses corresponding to the context of the + -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_ + -- High_Bound because we want Empty_Node to be a possible value. package Processed_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -148,11 +151,13 @@ package body Prj.Part is -- Check that an aggregate project only imports abstract projects procedure Create_Virtual_Extending_Project - (For_Project : Project_Node_Id; - Main_Project : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref); + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + Extension_Withs : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref); -- Create a virtual extending project of For_Project. Main_Project is - -- the extending all project. + -- the extending all project. Extension_Withs is the head of a WITH clause + -- list to be added to the created virtual project. -- -- The String_Value_Of is not set for the automatically added with -- clause and keeps the default value of No_Name. This enables Prj.PP @@ -236,14 +241,45 @@ package body Prj.Part is -- Returns No_Name if the path name is invalid, because the corresponding -- project name does not have the syntax of an ada identifier. + function Copy_With_Clause + (With_Clause : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Next_Clause : Project_Node_Id) return Project_Node_Id; + -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the + -- indicated one. + + ---------------------- + -- Copy_With_Clause -- + ---------------------- + + function Copy_With_Clause + (With_Clause : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Next_Clause : Project_Node_Id) return Project_Node_Id + is + New_With_Clause : constant Project_Node_Id := + Default_Project_Node (In_Tree, N_With_Clause); + begin + Set_Name_Of (New_With_Clause, In_Tree, + Name_Of (With_Clause, In_Tree)); + Set_Path_Name_Of (New_With_Clause, In_Tree, + Path_Name_Of (With_Clause, In_Tree)); + Set_Project_Node_Of (New_With_Clause, In_Tree, + Project_Node_Of (With_Clause, In_Tree)); + Set_Next_With_Clause_Of (New_With_Clause, In_Tree, Next_Clause); + + return New_With_Clause; + end Copy_With_Clause; + -------------------------------------- -- Create_Virtual_Extending_Project -- -------------------------------------- procedure Create_Virtual_Extending_Project - (For_Project : Project_Node_Id; - Main_Project : Project_Node_Id; - In_Tree : Project_Node_Tree_Ref) + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + Extension_Withs : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) is Virtual_Name : constant String := @@ -323,7 +359,8 @@ package body Prj.Part is Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree); - -- With clause + -- Add a WITH clause to the main project to import the newly created + -- virtual extending project. Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id); @@ -332,6 +369,21 @@ package body Prj.Part is (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree)); Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause); + -- Copy with clauses for projects imported by the extending-all project + + declare + Org_With_Clause : Project_Node_Id := Extension_Withs; + New_With_Clause : Project_Node_Id := Empty_Node; + begin + while Present (Org_With_Clause) loop + New_With_Clause := + Copy_With_Clause (Org_With_Clause, In_Tree, New_With_Clause); + + Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree); + end loop; + Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause); + end; + -- Virtual project node Set_Location_Of @@ -371,6 +423,14 @@ package body Prj.Part is -- Look_For_Virtual_Projects_For -- ----------------------------------- + Extension_Withs : Project_Node_Id; + -- Head of the current EXTENDS ALL imports list. When creating virtual + -- projects for an EXTENDS ALL, we import in each virtual project all + -- of the projects that appear in WITH clauses of the extending projects. + -- This ensures that virtual projects share a consistent environment (in + -- particular if a project imported by one of the extending projects + -- replaces some runtime units). + procedure Look_For_Virtual_Projects_For (Proj : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; @@ -388,9 +448,13 @@ package body Prj.Part is Extended : Project_Node_Id := Empty_Node; -- Node for the eventual project extended by Proj + Extends_All : Boolean := False; + -- Set True if Proj is an EXTENDS ALL project + + Saved_Extension_Withs : constant Project_Node_Id := Extension_Withs; + begin - -- Nothing to do if Proj is not defined or if it has already been - -- processed. + -- Nothing to do if Proj is undefined or has already been processed if Present (Proj) and then not Processed_Hash.Get (Proj) then -- Make sure the project will not be processed again @@ -401,13 +465,14 @@ package body Prj.Part is if Present (Declaration) then Extended := Extended_Project_Of (Declaration, In_Tree); + Extends_All := Is_Extending_All (Proj, In_Tree); end if; -- If this is a project that may need a virtual extending project -- and it is not itself an extending project, put it in the list. if Potentially_Virtual and then No (Extended) then - Virtual_Hash.Set (Proj, Proj); + Virtual_Hash.Set (Proj, Extension_Withs); end if; -- Now check the projects it imports @@ -422,6 +487,14 @@ package body Prj.Part is (Imported, In_Tree, Potentially_Virtual => True); end if; + if Extends_All then + -- This is an EXTENDS ALL project: prepend each of its WITH + -- clauses to the currently active list of extension deps. + + Extension_Withs := + Copy_With_Clause (With_Clause, In_Tree, Extension_Withs); + end if; + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; @@ -431,6 +504,8 @@ package body Prj.Part is Look_For_Virtual_Projects_For (Extended, In_Tree, Potentially_Virtual => False); + + Extension_Withs := Saved_Extension_Withs; end if; end Look_For_Virtual_Projects_For; @@ -550,6 +625,7 @@ package body Prj.Part is Declaration : constant Project_Node_Id := Project_Declaration_Of (Project, In_Tree); begin + Extension_Withs := First_With_Clause_Of (Project, In_Tree); Look_For_Virtual_Projects_For (Extended_Project_Of (Declaration, In_Tree), In_Tree, Potentially_Virtual => False); @@ -595,11 +671,14 @@ package body Prj.Part is -- Now create all the virtual extending projects declare - Proj : Project_Node_Id := Virtual_Hash.Get_First; + Proj : Project_Node_Id := Empty_Node; + Withs : Project_Node_Id; begin - while Present (Proj) loop - Create_Virtual_Extending_Project (Proj, Project, In_Tree); - Proj := Virtual_Hash.Get_Next; + Virtual_Hash.Get_First (Proj, Withs); + while Withs /= Project_Node_High_Bound loop + Create_Virtual_Extending_Project + (Proj, Project, Withs, In_Tree); + Virtual_Hash.Get_Next (Proj, Withs); end loop; end; end if; diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index cf0ae4a6619..6e9e61bc2a6 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -968,4 +968,15 @@ package body Prj.PP is Output.Write_Eol; end Output_Statistics; + --------- + -- wpr -- + --------- + + procedure wpr + (Project : Prj.Tree.Project_Node_Id; + In_Tree : Prj.Tree.Project_Node_Tree_Ref) is + begin + Pretty_Print (Project, In_Tree, Backward_Compatibility => False); + end wpr; + end Prj.PP; diff --git a/gcc/ada/prj-pp.ads b/gcc/ada/prj-pp.ads index f47e0582b35..771b4c3f2d4 100644 --- a/gcc/ada/prj-pp.ads +++ b/gcc/ada/prj-pp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -91,4 +91,9 @@ private -- display what Project_Node_Kinds have not been exercised by the call(s) -- to Pretty_Print. It is used only for testing purposes. + procedure wpr + (Project : Prj.Tree.Project_Node_Id; + In_Tree : Prj.Tree.Project_Node_Tree_Ref); + -- Wrapper for use from gdb: call Pretty_Print with default parameters + end Prj.PP; diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 813568deea6..df2ec7a888c 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -41,6 +41,9 @@ with Uname; use Uname; package body Restrict is + Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions; + -- Save compilation unit restrictions set by config pragma files + Restricted_Profile_Result : Boolean := False; -- This switch memoizes the result of Restricted_Profile function calls for -- improved efficiency. Valid only if Restricted_Profile_Cached is True. @@ -100,6 +103,17 @@ package body Restrict is end if; end Abort_Allowed; + ---------------------------------------- + -- Add_To_Config_Boolean_Restrictions -- + ---------------------------------------- + + procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is + begin + Config_Cunit_Boolean_Restrictions (R) := True; + end Add_To_Config_Boolean_Restrictions; + -- Add specified restriction to stored configuration boolean restrictions. + -- This is used for handling the special case of No_Elaboration_Code. + ------------------------- -- Check_Compiler_Unit -- ------------------------- @@ -183,6 +197,78 @@ package body Restrict is end if; end Check_SPARK_Restriction; + -------------------------------- + -- Check_No_Implicit_Aliasing -- + -------------------------------- + + procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is + E : Entity_Id; + + begin + -- If restriction not active, nothing to check + + if not Restriction_Active (No_Implicit_Aliasing) then + return; + end if; + + -- If we have an entity name, check entity + + if Is_Entity_Name (Obj) then + E := Entity (Obj); + + -- Restriction applies to entities that are objects + + if Is_Object (E) then + if Is_Aliased (E) then + return; + + elsif Present (Renamed_Object (E)) then + Check_No_Implicit_Aliasing (Renamed_Object (E)); + return; + end if; + + -- If we don't have an object, then it's OK + + else + return; + end if; + + -- For selected component, check selector + + elsif Nkind (Obj) = N_Selected_Component then + Check_No_Implicit_Aliasing (Selector_Name (Obj)); + return; + + -- Indexed component is OK if aliased components + + elsif Nkind (Obj) = N_Indexed_Component then + if Has_Aliased_Components (Etype (Prefix (Obj))) + or else + (Is_Access_Type (Etype (Prefix (Obj))) + and then Has_Aliased_Components + (Designated_Type (Etype (Prefix (Obj))))) + then + return; + end if; + + -- For type conversion, check converted expression + + elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then + Check_No_Implicit_Aliasing (Expression (Obj)); + return; + + -- Explicit dereference is always OK + + elsif Nkind (Obj) = N_Explicit_Dereference then + return; + end if; + + -- If we fall through, then we have an aliased view that does not meet + -- the rules for being explicitly aliased, so issue restriction msg. + + Check_Restriction (No_Implicit_Aliasing, Obj); + end Check_No_Implicit_Aliasing; + ----------------------------------------- -- Check_Implicit_Dynamic_Code_Allowed -- ----------------------------------------- @@ -426,7 +512,9 @@ package body Restrict is Update_Restrictions (Restrictions); - -- If in main extended unit, update main restrictions as well + -- If in main extended unit, update main restrictions as well. Note + -- that as usual we check for Main_Unit explicitly to deal with the + -- case of configuration pragma files. if Current_Sem_Unit = Main_Unit or else In_Extended_Main_Source_Unit (N) @@ -570,6 +658,16 @@ package body Restrict is for J in Cunit_Boolean_Restrictions loop Restrictions.Set (J) := R (J); end loop; + + -- If No_Elaboration_Code set in configuration restrictions, and we + -- in the main extended source, then set it here now. This is part of + -- the special processing for No_Elaboration_Code. + + if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit)) + and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code) + then + Restrictions.Set (No_Elaboration_Code) := True; + end if; end Cunit_Boolean_Restrictions_Restore; ------------------------------------- @@ -584,7 +682,6 @@ package body Restrict is begin for J in Cunit_Boolean_Restrictions loop R (J) := Restrictions.Set (J); - Restrictions.Set (J) := False; end loop; return R; @@ -700,6 +797,26 @@ package body Restrict is return New_Name; end Process_Restriction_Synonyms; + -------------------------------------- + -- Reset_Cunit_Boolean_Restrictions -- + -------------------------------------- + + procedure Reset_Cunit_Boolean_Restrictions is + begin + for J in Cunit_Boolean_Restrictions loop + Restrictions.Set (J) := False; + end loop; + end Reset_Cunit_Boolean_Restrictions; + + ----------------------------------------------- + -- Restore_Config_Cunit_Boolean_Restrictions -- + ----------------------------------------------- + + procedure Restore_Config_Cunit_Boolean_Restrictions is + begin + Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions); + end Restore_Config_Cunit_Boolean_Restrictions; + ------------------------ -- Restricted_Profile -- ------------------------ @@ -932,6 +1049,15 @@ package body Restrict is end if; end Same_Unit; + -------------------------------------------- + -- Save_Config_Cunit_Boolean_Restrictions -- + -------------------------------------------- + + procedure Save_Config_Cunit_Boolean_Restrictions is + begin + Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save; + end Save_Config_Cunit_Boolean_Restrictions; + ------------------------------ -- Set_Hidden_Part_In_SPARK -- ------------------------------ @@ -998,23 +1124,6 @@ package body Restrict is N : Node_Id) is begin - -- Restriction No_Elaboration_Code must be enforced on a unit by unit - -- basis. Hence, we avoid setting the restriction when processing an - -- unit which is not the main one being compiled (or its corresponding - -- spec). It can happen, for example, when processing an inlined body - -- (the package containing the inlined subprogram is analyzed, - -- including its pragma Restrictions). - - -- This seems like a very nasty kludge??? This is not the only per unit - -- restriction why is this treated specially ??? - - if R = No_Elaboration_Code - and then Current_Sem_Unit /= Main_Unit - and then Cunit (Current_Sem_Unit) /= Library_Unit (Cunit (Main_Unit)) - then - return; - end if; - Restrictions.Set (R) := True; if Restricted_Profile_Cached and Restricted_Profile_Result then diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 10875025e2b..5d03f831267 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -71,10 +71,6 @@ package Restrict is -- set if Restriction_Warnings is set, so this does not look like a -- restriction to the binder. - type Save_Cunit_Boolean_Restrictions is private; - -- Type used for saving and restoring compilation unit restrictions. - -- See Cunit_Boolean_Restrictions_[Save|Restore] subprograms. - -- The following declarations establish a mapping between restriction -- identifiers, and the names of corresponding restriction library units. @@ -279,6 +275,13 @@ package Restrict is -- Same as Check_SPARK_Restriction except there is a continuation message -- Msg2 following the initial message Msg1. + procedure Check_No_Implicit_Aliasing (Obj : Node_Id); + -- Obj is a node for which Is_Aliased_View is True, which is being used in + -- a context (e.g. 'Access) where no implicit aliasing is allowed if the + -- restriction No_Implicit_Aliasing is set. This procedure checks for the + -- case where the restriction is active and Obj does not meet the required + -- rules for avoiding implicit aliases, and issues a restriction message. + procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id); -- Tests to see if dynamic code generation (dynamically generated -- trampolines, in particular) is allowed by the current restrictions @@ -305,22 +308,6 @@ package Restrict is -- [Wide_]Wide_Character or [Wide_]Wide_String, then the restriction -- violation is recorded, and an appropriate message given. - function Cunit_Boolean_Restrictions_Save - return Save_Cunit_Boolean_Restrictions; - -- This function saves the compilation unit restriction settings, and - -- resets them to False. This is used e.g. when compiling a with'ed - -- unit to avoid incorrectly propagating restrictions. Note that it - -- would not be wrong to also save and reset the partition restrictions, - -- since the binder would catch inconsistencies, but actually it is a - -- good thing to acquire restrictions from with'ed units if they are - -- required to be partition wide, because it allows the restriction - -- violation message to be given at compile time instead of link time. - - procedure Cunit_Boolean_Restrictions_Restore - (R : Save_Cunit_Boolean_Restrictions); - -- This is the corresponding restore procedure to restore restrictions - -- previously saved by Cunit_Boolean_Restrictions_Save. - function Get_Restriction_Id (N : Name_Id) return Restriction_Id; -- Given an identifier name, determines if it is a valid restriction @@ -428,6 +415,71 @@ package Restrict is -- Tests if tasking operations are allowed by the current restrictions -- settings. For tasking to be allowed Max_Tasks must be non-zero. + ---------------------------------------------- + -- Handling of Boolean Compilation Switches -- + ---------------------------------------------- + + -- The following declarations are used for proper saving and restoring of + -- restrictions for separate compilation units. There are two cases: + + -- For partition-wide restrictions, we just let the restrictions pragmas + -- pile up, and we never reset them. We might as well detect what we can + -- at compile time. If e.g. a with'ed unit has a restriction for one of + -- the partition-wide restrictions, then the binder will enforce it on + -- all units in the partition, including the unit with the WITH. Although + -- it would not be wrong to leave this till bind time, we might as well + -- flag it earlier at compile time. + + -- For non-partition-wide restrictions, we have quite a different state + -- of affairs. Here it would be quite wrong to carry a restriction from + -- a with'ed unit to another with'ed unit, or from a package spec to the + -- package body. This means that we have to reset these non-partition + -- wide restrictions at the start of each separate compilation unit. For + -- units in the extended main program, we need to reset them all to the + -- values set by the configuration pragma file(s). For units not in the + -- extended main program, e.g. with'ed units, we might as well reset all + -- of these restrictions to off (False). The actual initial values will + -- be taken from the config files active when those units are compiled + -- as main units. + + type Save_Cunit_Boolean_Restrictions is private; + -- Type used for saving and restoring compilation unit restrictions. + + function Cunit_Boolean_Restrictions_Save + return Save_Cunit_Boolean_Restrictions; + -- This function saves the compilation unit restriction settings, leaving + -- then unchanged. This is used e.g. at the start of processing a context + -- clause, so that the main unit restrictions can be restored after all + -- the with'ed units have been processed. + + procedure Cunit_Boolean_Restrictions_Restore + (R : Save_Cunit_Boolean_Restrictions); + -- This is the corresponding restore procedure to restore restrictions + -- previously saved by Cunit_Boolean_Restrictions_Save. However it does + -- not reset No_Elaboration_Code, this stays set if it was set before + -- the call, and also if it is set before the call, then the Config + -- setting is also updated to include this restriction. This is what + -- implements the special handling of No_Elaboration_Code. + + procedure Save_Config_Cunit_Boolean_Restrictions; + -- This saves the current compilation unit restrictions in an internal + -- variable, and leaves them unchanged. This is called immediately after + -- processing the configuration file pragmas, to record the restrictions + -- set by these configuration file pragmas. + + procedure Restore_Config_Cunit_Boolean_Restrictions; + -- This restores the value saved by the previous call to save config values + -- saved by Save_Config_Cunit_Boolean_Restrictions. It is called at the + -- start of processing a new unit that is part of the main sources (e.g. + -- a package spec when the main unit is a package body). + + procedure Reset_Cunit_Boolean_Restrictions; + -- Turns off all non-partition-wide boolean restrictions + + procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id); + -- Add specified restriction to stored configuration boolean restrictions. + -- This is used for handling the special case of No_Elaboration_Code. + private type Save_Cunit_Boolean_Restrictions is array (Cunit_Boolean_Restrictions) of Boolean; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index b7a02066b77..261365d9292 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1353,6 +1353,7 @@ package Rtsfind is RE_Allocate_Any_Controlled, -- System.Storage_Pools.Subpools RE_Deallocate_Any_Controlled, -- System.Storage_Pools.Subpools + RE_Header_Size_With_Padding, -- System.Storage_Pools.Subpools RE_Root_Storage_Pool_With_Subpools, -- System.Storage_Pools.Subpools RE_Root_Subpool, -- System.Storage_Pools.Subpools RE_Subpool_Handle, -- System.Storage_Pools.Subpools @@ -2550,6 +2551,7 @@ package Rtsfind is RE_Allocate_Any_Controlled => System_Storage_Pools_Subpools, RE_Deallocate_Any_Controlled => System_Storage_Pools_Subpools, + RE_Header_Size_With_Padding => System_Storage_Pools_Subpools, RE_Root_Storage_Pool_With_Subpools => System_Storage_Pools_Subpools, RE_Root_Subpool => System_Storage_Pools_Subpools, RE_Subpool_Handle => System_Storage_Pools_Subpools, diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb index 8ec851e8f20..f230721af00 100644 --- a/gcc/ada/s-atocou-builtin.adb +++ b/gcc/ada/s-atocou-builtin.adb @@ -50,7 +50,12 @@ package body System.Atomic_Counters is function Decrement (Item : in out Atomic_Counter) return Boolean is begin - return Sync_Sub_And_Fetch (Item.Value'Access, 1) = 0; + -- Note: the use of Unrestricted_Access here is required because we + -- are obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0; end Decrement; --------------- @@ -59,7 +64,12 @@ package body System.Atomic_Counters is procedure Increment (Item : in out Atomic_Counter) is begin - Sync_Add_And_Fetch (Item.Value'Access, 1); + -- Note: the use of Unrestricted_Access here is required because we + -- are obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1); end Increment; ------------ diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index 8474ff4a8f3..918519b6781 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -181,6 +181,12 @@ package body System.Finalization_Masters is if Master.Finalization_Started then Unlock_Task.all; + + -- Double finalization may occur during the handling of stand alone + -- libraries or the finalization of a pool with subpools. Due to the + -- potential aliasing of masters in these two cases, do not process + -- the same master twice. + return; end if; diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 1c63e386ea9..3599261498c 100755 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -174,7 +174,7 @@ package System.OS_Lib is -- File descriptors for standard input output files Invalid_FD : constant File_Descriptor := -1; - -- File descriptor returned when error in opening/creating file; + -- File descriptor returned when error in opening/creating file type Mode is (Binary, Text); for Mode'Size use Integer'Size; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index ad3d06520d8..3d70ceb4857 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -97,6 +97,7 @@ pragma Style_Checks ("M32766"); #include <string.h> #include <limits.h> #include <fcntl.h> +#include <time.h> #if defined (__alpha__) && defined (__osf__) /** Tru64 is unable to do vector IO operations with default value of IOV_MAX, @@ -145,7 +146,7 @@ pragma Style_Checks ("M32766"); # define NATIVE -#endif +#endif /* DUMMY */ #ifndef TARGET # error Please define TARGET @@ -212,7 +213,7 @@ int counter = 0; : : "i" (__LINE__)); /* Freeform text */ -#endif +#endif /* NATIVE */ #define CST(name,comment) C(#name,String,name,comment) @@ -925,6 +926,21 @@ CND(VEOL2, "Alternative EOL") #endif /* HAVE_TERMIOS */ +/* + + ----------------------------- + -- Pseudo terminal library -- + ----------------------------- + +*/ + +#if defined (__FreeBSD__) || defined (linux) +# define PTY_Library "-lutil" +#else +# define PTY_Library "" +#endif +CST(PTY_Library, "for g-exptty") + /** ** Sockets constants **/ @@ -1317,58 +1333,71 @@ CST(Inet_Pton_Linkname, "") #endif /* HAVE_SOCKETS */ -/** - ** System-specific constants follow - ** Each section should be activated if compiling for the corresponding - ** platform *or* generating the dummy version for runtime test compilation. - **/ - -#if defined (__vxworks) || defined (DUMMY) - /* - -------------------------------- - -- VxWorks-specific constants -- - -------------------------------- + --------------------- + -- Threads support -- + --------------------- + + -- Clock identifier definitions - -- These constants may be used only within the VxWorks version of - -- GNAT.Sockets.Thin. */ -CND(OK, "VxWorks generic success") -CND(ERROR, "VxWorks generic error") +#ifdef CLOCK_REALTIME +CND(CLOCK_REALTIME, "System realtime clock") +#endif +#ifdef CLOCK_MONOTONIC +CND(CLOCK_MONOTONIC, "System monotonic clock") #endif -#if defined (__MINGW32__) || defined (DUMMY) -/* +#ifdef CLOCK_FASTEST +CND(CLOCK_FASTEST, "Fastest clock") +#endif - ------------------------------ - -- MinGW-specific constants -- - ------------------------------ +#if defined (__sgi) +CND(CLOCK_SGI_FAST, "SGI fast clock") +CND(CLOCK_SGI_CYCLE, "SGI CPU clock") +#endif - -- These constants may be used only within the MinGW version of - -- GNAT.Sockets.Thin. -*/ +#ifndef CLOCK_THREAD_CPUTIME_ID +# define CLOCK_THREAD_CPUTIME_ID -1 +#endif +CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock") -CND(WSASYSNOTREADY, "System not ready") -CND(WSAVERNOTSUPPORTED, "Version not supported") -CND(WSANOTINITIALISED, "Winsock not initialized") -CND(WSAEDISCON, "Disconnected") +#if defined(__APPLE__) +/* There's no clock_gettime or clock_id's on Darwin, generate a dummy value */ +# define CLOCK_RT_Ada "-1" +#elif defined(FreeBSD) || (defined(_AIX) && defined(_AIXVERSION_530)) +/** On these platforms use system provided monotonic clock instead of + ** the default CLOCK_REALTIME. We then need to set up cond var attributes + ** appropriately (see thread.c). + **/ +# define CLOCK_RT_Ada "CLOCK_MONOTONIC" +# define NEED_PTHREAD_CONDATTR_SETCLOCK + +#elif defined(CLOCK_REALTIME) +/* By default use CLOCK_REALTIME */ +# define CLOCK_RT_Ada "CLOCK_REALTIME" #endif -#ifdef NATIVE - putchar ('\n'); +#ifdef CLOCK_RT_Ada +CNS(CLOCK_RT_Ada, "") #endif #if defined (__APPLE__) || defined (__linux__) || defined (DUMMY) /* - -- Sizes of pthread data types (on Darwin these are padding) + -- Sizes of pthread data types + */ #if defined (__APPLE__) || defined (DUMMY) +/* + -- (on Darwin, these are just placeholders) + +*/ #define PTHREAD_SIZE __PTHREAD_SIZE__ #define PTHREAD_ATTR_SIZE __PTHREAD_ATTR_SIZE__ #define PTHREAD_MUTEXATTR_SIZE __PTHREAD_MUTEXATTR_SIZE__ @@ -1390,24 +1419,65 @@ CND(WSAEDISCON, "Disconnected") #define PTHREAD_ONCE_SIZE (sizeof (pthread_once_t)) #endif -CND(PTHREAD_SIZE, "pthread_t") +CND(PTHREAD_SIZE, "pthread_t") +CND(PTHREAD_ATTR_SIZE, "pthread_attr_t") +CND(PTHREAD_MUTEXATTR_SIZE, "pthread_mutexattr_t") +CND(PTHREAD_MUTEX_SIZE, "pthread_mutex_t") +CND(PTHREAD_CONDATTR_SIZE, "pthread_condattr_t") +CND(PTHREAD_COND_SIZE, "pthread_cond_t") +CND(PTHREAD_RWLOCKATTR_SIZE, "pthread_rwlockattr_t") +CND(PTHREAD_RWLOCK_SIZE, "pthread_rwlock_t") +CND(PTHREAD_ONCE_SIZE, "pthread_once_t") -CND(PTHREAD_ATTR_SIZE, "pthread_attr_t") +#endif /* __APPLE__ || __linux__ */ -CND(PTHREAD_MUTEXATTR_SIZE, "pthread_mutexattr_t") +/** + ** System-specific constants follow + ** Each section should be activated if compiling for the corresponding + ** platform *or* generating the dummy version for runtime test compilation. + **/ -CND(PTHREAD_MUTEX_SIZE, "pthread_mutex_t") +#if defined (__vxworks) || defined (DUMMY) -CND(PTHREAD_CONDATTR_SIZE, "pthread_condattr_t") +/* -CND(PTHREAD_COND_SIZE, "pthread_cond_t") + -------------------------------- + -- VxWorks-specific constants -- + -------------------------------- -CND(PTHREAD_RWLOCKATTR_SIZE, "pthread_rwlockattr_t") + -- These constants may be used only within the VxWorks version of + -- GNAT.Sockets.Thin. +*/ + +CND(OK, "VxWorks generic success") +CND(ERROR, "VxWorks generic error") + +#endif /* __vxworks */ + +#if defined (__MINGW32__) || defined (DUMMY) +/* -CND(PTHREAD_RWLOCK_SIZE, "pthread_rwlock_t") + ------------------------------ + -- MinGW-specific constants -- + ------------------------------ -CND(PTHREAD_ONCE_SIZE, "pthread_once_t") + -- These constants may be used only within the MinGW version of + -- GNAT.Sockets.Thin. +*/ +CND(WSASYSNOTREADY, "System not ready") +CND(WSAVERNOTSUPPORTED, "Version not supported") +CND(WSANOTINITIALISED, "Winsock not initialized") +CND(WSAEDISCON, "Disconnected") + +#endif /* __MINGW32__ */ + +/** + ** End of constants definitions + **/ + +#ifdef NATIVE + putchar ('\n'); #endif /* diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads index c8e66082604..c89e7296e14 100644 --- a/gcc/ada/s-osinte-aix.ads +++ b/gcc/ada/s-osinte-aix.ads @@ -197,10 +197,7 @@ package System.OS_Interface is type timespec is private; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_MONOTONIC : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -547,10 +544,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 9; - CLOCK_MONOTONIC : constant clockid_t := 10; - type pthread_attr_t is new System.Address; pragma Convention (C, pthread_attr_t); -- typedef struct __pt_attr *pthread_attr_t; diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index fe2a10a3315..ff0480379bc 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -183,10 +183,7 @@ package System.OS_Interface is type timespec is private; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_MONOTONIC : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -524,10 +521,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME; - -- -- Darwin specific signal implementation -- diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads index cbd2a2df428..b581dae2e20 100644 --- a/gcc/ada/s-osinte-freebsd.ads +++ b/gcc/ada/s-osinte-freebsd.ads @@ -200,10 +200,7 @@ package System.OS_Interface is function nanosleep (rqtp, rmtp : access timespec) return int; pragma Import (C, nanosleep, "nanosleep"); - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_MONOTONIC : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -643,13 +640,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - CLOCK_MONOTONIC : constant clockid_t := 0; - -- On FreeBSD, pthread_cond_timedwait assumes a CLOCK_REALTIME time by - -- default (unless pthread_condattr_setclock is used to set an alternate - -- clock). - type pthread_t is new System.Address; type pthread_attr_t is new System.Address; type pthread_mutex_t is new System.Address; diff --git a/gcc/ada/s-osinte-hpux-dce.ads b/gcc/ada/s-osinte-hpux-dce.ads index f39cbfdec34..3d873e1163c 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-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2011, 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- -- @@ -193,9 +193,7 @@ package System.OS_Interface is function nanosleep (rqtp, rmtp : access timespec) return int; pragma Import (C, nanosleep); - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; + type clockid_t is new int; function Clock_Gettime (Clock_Id : clockid_t; Tp : access timespec) return int; diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads index bc9a7091d6f..55729f877ab 100644 --- a/gcc/ada/s-osinte-hpux.ads +++ b/gcc/ada/s-osinte-hpux.ads @@ -180,10 +180,7 @@ package System.OS_Interface is type timespec is private; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_MONOTONIC : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -529,10 +526,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 1; - CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME; - type pthread_attr_t is new int; type pthread_condattr_t is new int; type pthread_mutexattr_t is new int; diff --git a/gcc/ada/s-osinte-irix.ads b/gcc/ada/s-osinte-irix.ads index ddeadcb6147..365a3de2dca 100644 --- a/gcc/ada/s-osinte-irix.ads +++ b/gcc/ada/s-osinte-irix.ads @@ -172,11 +172,7 @@ package System.OS_Interface is type timespec is private; type timespec_ptr is access all timespec; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_SGI_FAST : constant clockid_t; - CLOCK_SGI_CYCLE : constant clockid_t; + type clockid_t is new int; SGI_CYCLECNTR_SIZE : constant := 165; @@ -486,11 +482,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 1; - CLOCK_SGI_CYCLE : constant clockid_t := 2; - CLOCK_SGI_FAST : constant clockid_t := 3; - type array_type_9 is array (Integer range 0 .. 4) of long; type pthread_attr_t is record X_X_D : array_type_9; diff --git a/gcc/ada/s-osinte-lynxos-3.ads b/gcc/ada/s-osinte-lynxos-3.ads index 3d912eefee2..e8288d9f6dd 100644 --- a/gcc/ada/s-osinte-lynxos-3.ads +++ b/gcc/ada/s-osinte-lynxos-3.ads @@ -177,9 +177,7 @@ package System.OS_Interface is type timespec is private; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -516,9 +514,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new unsigned_char; - CLOCK_REALTIME : constant clockid_t := 0; - type st_t is record stksize : int; prio : int; diff --git a/gcc/ada/s-osinte-lynxos.ads b/gcc/ada/s-osinte-lynxos.ads index 8b998bcfdf6..7bcbab6072e 100644 --- a/gcc/ada/s-osinte-lynxos.ads +++ b/gcc/ada/s-osinte-lynxos.ads @@ -197,10 +197,7 @@ package System.OS_Interface is type timespec is private; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_MONOTONIC : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -517,10 +514,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new unsigned_char; - CLOCK_REALTIME : constant clockid_t := 1; - CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME; - type st_attr_t is record stksize : int; prio : int; diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads index 8781a12dd67..eb17bd4e25f 100644 --- a/gcc/ada/s-osinte-solaris-posix.ads +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -187,10 +187,7 @@ package System.OS_Interface is type timespec is private; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_MONOTONIC : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -520,10 +517,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 3; - CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME; - type pthread_attr_t is record pthread_attrp : System.Address; end record; diff --git a/gcc/ada/s-osinte-solaris.ads b/gcc/ada/s-osinte-solaris.ads index 03a0c4ae47d..b4baa6d4998 100644 --- a/gcc/ada/s-osinte-solaris.ads +++ b/gcc/ada/s-osinte-solaris.ads @@ -243,9 +243,7 @@ package System.OS_Interface is type timespec is private; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; tp : access timespec) return int; @@ -531,9 +529,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - type array_type_9 is array (0 .. 3) of unsigned_char; type record_type_3 is record flag : array_type_9; diff --git a/gcc/ada/s-osinte-tru64.ads b/gcc/ada/s-osinte-tru64.ads index 83471727b1b..0fcd4221e80 100644 --- a/gcc/ada/s-osinte-tru64.ads +++ b/gcc/ada/s-osinte-tru64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -191,9 +191,7 @@ package System.OS_Interface is function nanosleep (rqtp, rmtp : access timespec) return int; pragma Import (C, nanosleep); - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; + type clockid_t is new int; function clock_gettime (clock_id : clockid_t; @@ -506,9 +504,6 @@ private end record; pragma Convention (C, timespec); - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 1; - type unsigned_long_array is array (Natural range <>) of unsigned_long; type pthread_t is new System.Address; diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads index f5013ea6977..19976740463 100644 --- a/gcc/ada/s-osinte-vxworks.ads +++ b/gcc/ada/s-osinte-vxworks.ads @@ -243,9 +243,7 @@ package System.OS_Interface is end record; pragma Convention (C, timespec); - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock + type clockid_t is new int; function To_Duration (TS : timespec) return Duration; pragma Inline (To_Duration); @@ -511,8 +509,5 @@ private ERROR_PID : constant pid_t := -1; - 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-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb index f75850af026..1eccae5612a 100644 --- a/gcc/ada/s-osprim-vxworks.adb +++ b/gcc/ada/s-osprim-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2011, 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- -- @@ -37,6 +37,7 @@ with System.OS_Interface; -- set of C imported routines: using Ada routines from this package would -- create a dependency on libgnarl in libgnat, which is not desirable. +with System.OS_Constants; with Interfaces.C; package body System.OS_Primitives is @@ -44,6 +45,8 @@ package body System.OS_Primitives is use System.OS_Interface; use type Interfaces.C.int; + package OSC renames System.OS_Constants; + ------------------------ -- Internal functions -- ------------------------ @@ -94,7 +97,7 @@ package body System.OS_Primitives is TS : aliased timespec; Result : int; begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; end Clock; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 1c306e34664..d067f3d7f4f 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -124,7 +124,15 @@ package System.Rident is No_Default_Initialization, -- GNAT - -- The following cases do not require consistency checking + -- The following cases do not require consistency checking and if used + -- as a configuration pragma within a specific unit, apply only to that + -- unit (e.g. if used in the package spec, do not apply to the body) + + -- Note: No_Elaboration_Code is handled specially. Like the other + -- non-partition-wide restrictions, it can only be set in a unit that + -- is part of the extended main source unit (body/spec/subunits). But + -- it is sticky, in that if it is found anywhere within any of these + -- units, it applies to all units in this extended main source. Immediate_Reclamation, -- (RM H.4(10)) No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 @@ -202,7 +210,7 @@ package System.Rident is -- Boolean restrictions that are not checked for partition consistency -- and that thus apply only to the current unit. Note that for these -- restrictions, the compiler does not apply restrictions found in - -- with'ed units, parent specs etc. to the main unit. + -- with'ed units, parent specs etc. to the main unit, and vice versa. subtype All_Parameter_Restrictions is Restriction_Id range diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index 4bbff767d96..78958412ab2 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -56,12 +56,6 @@ package body System.Storage_Pools.Subpools is procedure Detach (N : not null SP_Node_Ptr); -- Unhook a subpool node from an arbitrary subpool list - function Nearest_Multiple_Rounded_Up - (Size : Storage_Count; - Alignment : Storage_Count) return Storage_Count; - -- Given arbitrary values of storage size and alignment, calculate the - -- nearest multiple of the alignment rounded up where size can fit. - -------------- -- Allocate -- -------------- @@ -218,10 +212,7 @@ package body System.Storage_Pools.Subpools is -- Account for possible padding space before the header due to a -- larger alignment. - Header_And_Padding := - Nearest_Multiple_Rounded_Up - (Size => Header_Size, - Alignment => Alignment); + Header_And_Padding := Header_Size_With_Padding (Alignment); N_Size := Storage_Size + Header_And_Padding; @@ -388,10 +379,7 @@ package body System.Storage_Pools.Subpools is -- Account for possible padding space before the header due to a -- larger alignment. - Header_And_Padding := - Nearest_Multiple_Rounded_Up - (Size => Header_Size, - Alignment => Alignment); + Header_And_Padding := Header_Size_With_Padding (Alignment); -- N_Addr N_Ptr Addr (from input) -- | | | @@ -571,6 +559,28 @@ package body System.Storage_Pools.Subpools is Free (Subpool.Node); end Finalize_Subpool; + ------------------------------ + -- Header_Size_With_Padding -- + ------------------------------ + + function Header_Size_With_Padding + (Alignment : System.Storage_Elements.Storage_Count) + return System.Storage_Elements.Storage_Count + is + Size : constant Storage_Count := Header_Size; + + begin + if Size mod Alignment = 0 then + return Size; + + -- Add enough padding to reach the nearest multiple of the alignment + -- rounding up. + + else + return ((Size + Alignment - 1) / Alignment) * Alignment; + end if; + end Header_Size_With_Padding; + ---------------- -- Initialize -- ---------------- @@ -592,26 +602,6 @@ package body System.Storage_Pools.Subpools is Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access; end Initialize_Pool; - --------------------------------- - -- Nearest_Multiple_Rounded_Up -- - --------------------------------- - - function Nearest_Multiple_Rounded_Up - (Size : Storage_Count; - Alignment : Storage_Count) return Storage_Count - is - begin - if Size mod Alignment = 0 then - return Size; - - -- Add enough padding to reach the nearest multiple of the alignment - -- rounding up. - - else - return ((Size + Alignment - 1) / Alignment) * Alignment; - end if; - end Nearest_Multiple_Rounded_Up; - --------------------- -- Pool_Of_Subpool -- --------------------- diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads index 0c5bd218515..38f8cfc73a3 100644 --- a/gcc/ada/s-stposu.ads +++ b/gcc/ada/s-stposu.ads @@ -329,6 +329,13 @@ private -- subpool from its owner's list. Deallocate the associated doubly linked -- list node. + function Header_Size_With_Padding + (Alignment : System.Storage_Elements.Storage_Count) + return System.Storage_Elements.Storage_Count; + -- Given an arbitrary alignment, calculate the size of the header which + -- precedes a controlled object as the nearest multiple rounded up of the + -- alignment. + overriding procedure Initialize (Controller : in out Pool_Controller); -- Buffer routine, calls Initialize_Pool diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 346de43ba05..1c5dcc1a024 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -44,6 +44,7 @@ with Interfaces.C; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Primitives.Interrupt_Operations; @@ -60,6 +61,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; @@ -555,7 +557,7 @@ package body System.Task_Primitives.Operations is TS : aliased timespec; Result : Interfaces.C.int; begin - Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access); + Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 5b4d4bef16e..8893c010571 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -45,6 +45,7 @@ with Interfaces.C; with System.Task_Info; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.IO; @@ -56,6 +57,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking; @@ -89,8 +91,6 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME; - Unblocked_Signal_Mask : aliased sigset_t; Foreign_Task_Elaborated : aliased Boolean := True; @@ -572,7 +572,7 @@ package body System.Task_Primitives.Operations is TS : aliased timespec; Result : Interfaces.C.int; begin - Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; @@ -583,7 +583,7 @@ package body System.Task_Primitives.Operations is function RT_Resolution return Duration is begin - -- The clock_getres (Real_Time_Clock_Id) function appears to return + -- The clock_getres (OSC.CLOCK_RT_Ada) function appears to return -- the interrupt resolution of the realtime clock and not the actual -- resolution of reading the clock. Even though this last value is -- only guaranteed to be 100 Hz, at least the Origin 200 appears to @@ -836,9 +836,15 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + Result := pthread_create - (T.Common.LL.Thread'Access, + (T.Common.LL.Thread'Unrestricted_Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); @@ -865,9 +871,15 @@ package body System.Task_Primitives.Operations is (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); pragma Assert (Result = 0); + -- Note: the use of Unrestricted_Access in the following call + -- is needed because otherwise we have an error of getting a + -- access-to-volatile value which points to a non-volatile object. + -- But in this case it is safe to do this, since we know we have no + -- aliasing problems and Unrestricted_Access bypasses this check. + Result := pthread_create - (T.Common.LL.Thread'Access, + (T.Common.LL.Thread'Unrestricted_Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index c63d5531b62..4e69ea4b321 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -291,14 +291,10 @@ package body System.Task_Primitives.Operations is else declare - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; + Result : Interfaces.C.int; begin - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_mutex_init (L.WO'Access, Mutex_Attr'Access); + Result := pthread_mutex_init (L.WO'Access, null); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -315,14 +311,10 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Level); - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; + Result : Interfaces.C.int; begin - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_mutex_init (L, Mutex_Attr'Access); + Result := pthread_mutex_init (L, null); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -817,9 +809,8 @@ package body System.Task_Primitives.Operations is -------------------- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + Result : Interfaces.C.int; begin -- Give the task a unique serial number @@ -831,11 +822,8 @@ package body System.Task_Primitives.Operations is Self_ID.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0); - Result := - pthread_mutex_init (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); + pthread_mutex_init (Self_ID.Common.LL.L'Access, null); pragma Assert (Result = 0 or else Result = ENOMEM); if Result /= 0 then @@ -1002,11 +990,18 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + + Result := + pthread_create + (T.Common.LL.Thread'Unrestricted_Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); pragma Assert (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); @@ -1081,9 +1076,7 @@ package body System.Task_Primitives.Operations is ---------------- procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; + Result : Interfaces.C.int; begin -- Initialize internal state (always to False (RM D.10(6))) @@ -1093,10 +1086,7 @@ package body System.Task_Primitives.Operations is -- Initialize internal mutex - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); + Result := pthread_mutex_init (S.L'Access, null); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -1106,10 +1096,7 @@ package body System.Task_Primitives.Operations is -- Initialize internal condition variable - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); + Result := pthread_cond_init (S.CV'Access, null); pragma Assert (Result = 0 or else Result = ENOMEM); diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 425508a32c2..667603b73b7 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -50,6 +50,7 @@ with Interfaces.C; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Info; @@ -61,6 +62,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; @@ -171,6 +173,11 @@ package body System.Task_Primitives.Operations is function To_Address is new Ada.Unchecked_Conversion (Task_Id, System.Address); + function GNAT_pthread_condattr_setup + (attr : access pthread_condattr_t) return int; + pragma Import (C, + GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + ------------------- -- Abort_Handler -- ------------------- @@ -666,7 +673,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin Result := clock_gettime - (clock_id => CLOCK_MONOTONIC, tp => TS'Unchecked_Access); + (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; @@ -869,6 +876,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then + Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); + pragma Assert (Result = 0); + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); @@ -975,8 +985,14 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + Result := pthread_create - (T.Common.LL.Thread'Access, + (T.Common.LL.Thread'Unrestricted_Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); @@ -1093,6 +1109,10 @@ package body System.Task_Primitives.Operations is -- underlying OS entities fails. raise Storage_Error; + + else + Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); + pragma Assert (Result = 0); end if; Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index b5fe1ee9d42..92088e10cb4 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -43,6 +43,7 @@ with Interfaces.C; with System.Multiprocessors; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Info; @@ -58,6 +59,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; @@ -773,7 +775,7 @@ package body System.Task_Primitives.Operations is TS : aliased timespec; Result : Interfaces.C.int; begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; @@ -1005,6 +1007,12 @@ package body System.Task_Primitives.Operations is Opts := THR_DETACHED + THR_BOUND; end if; + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + Result := thr_create (System.Null_Address, @@ -1012,7 +1020,7 @@ package body System.Task_Primitives.Operations is Thread_Body_Access (Wrapper), To_Address (T), Opts, - T.Common.LL.Thread'Access); + T.Common.LL.Thread'Unrestricted_Access); Succeeded := Result = 0; pragma Assert diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index b0b727d9bb1..8d69e5b19b1 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -43,6 +43,7 @@ with Interfaces.C; with System.Tasking.Debug; with System.Interrupt_Management; +with System.OS_Constants; with System.OS_Primitives; with System.Task_Info; @@ -54,6 +55,7 @@ with System.Soft_Links; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; @@ -589,7 +591,7 @@ package body System.Task_Primitives.Operations is TS : aliased timespec; Result : Interfaces.C.int; begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; @@ -887,9 +889,15 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + Result := pthread_create - (T.Common.LL.Thread'Access, + (T.Common.LL.Thread'Unrestricted_Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 92b6023bdff..67cf363dd4e 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -809,9 +809,15 @@ package body System.Task_Primitives.Operations is (Attributes'Access, PTHREAD_EXPLICIT_SCHED); pragma Assert (Result = 0); + -- Note: the use of Unrestricted_Access in the following call is needed + -- because otherwise we have an error of getting a access-to-volatile + -- value which points to a non-volatile object. But in this case it is + -- safe to do this, since we know we have no problems with aliasing and + -- Unrestricted_Access bypasses this check. + Result := pthread_create - (T.Common.LL.Thread'Access, + (T.Common.LL.Thread'Unrestricted_Access, Attributes'Access, Thread_Body_Access (Wrapper), To_Address (T)); diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index be76162b284..eec3a9da10d 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -46,6 +46,7 @@ with System.Multiprocessors; with System.Tasking.Debug; with System.Interrupt_Management; with System.Float_Control; +with System.OS_Constants; with System.Soft_Links; -- We use System.Soft_Links instead of System.Tasking.Initialization @@ -58,6 +59,7 @@ with System.VxWorks.Ext; package body System.Task_Primitives.Operations is + package OSC renames System.OS_Constants; package SSL renames System.Soft_Links; use System.Tasking.Debug; @@ -718,7 +720,7 @@ package body System.Task_Primitives.Operations is TS : aliased timespec; Result : int; begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; diff --git a/gcc/ada/s-utf_32.adb b/gcc/ada/s-utf_32.adb index a5af4fbc60e..f044b9bcc70 100755 --- a/gcc/ada/s-utf_32.adb +++ b/gcc/ada/s-utf_32.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -6182,6 +6182,7 @@ package body System.UTF_32 is function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean is begin return U in 10 .. 13 -- Ascii.LF Ascii.VT Ascii.FF Ascii.CR + or else U = 16#00085# -- NEL or else U = 16#02028# -- LINE SEPARATOR or else U = 16#02029#; -- PARAGRAPH SEPARATOR end Is_UTF_32_Line_Terminator; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index b463d37a938..2a273609a09 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -35,6 +35,7 @@ with Lib; use Lib; with Lib.Load; use Lib.Load; with Nlists; use Nlists; with Output; use Output; +with Restrict; use Restrict; with Sem_Attr; use Sem_Attr; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; @@ -1361,6 +1362,11 @@ package body Sem is -- Variable used to save values of config switches while we analyze the -- new unit, to be restored on exit for proper recursive behavior. + Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions; + -- Used to save non-partition wide restrictions before processing new + -- unit. All with'ed units are analyzed with config restrictions reset + -- and we need to restore these saved values at the end. + procedure Do_Analyze; -- Procedure to analyze the compilation unit. This is called more than -- once when the high level optimizer is activated. @@ -1442,11 +1448,27 @@ package body Sem is In_Spec_Expression := False; Set_Comes_From_Source_Default (False); + + -- Save current config switches and reset then appropriately + Save_Opt_Config_Switches (Save_Config_Switches); Set_Opt_Config_Switches (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)), Current_Sem_Unit = Main_Unit); + -- Save current non-partition-wide restrictions + + Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save; + + -- For unit in main extended unit, we reset the configuration values + -- for the non-partition-wide restrictions. For other units reset them. + + if In_Extended_Main_Source_Unit (Comp_Unit) then + Restore_Config_Cunit_Boolean_Restrictions; + else + Reset_Cunit_Boolean_Restrictions; + end if; + -- Only do analysis of unit that has not already been analyzed if not Analyzed (Comp_Unit) then @@ -1511,6 +1533,11 @@ package body Sem is Outer_Generic_Scope := S_Outer_Gen_Scope; Restore_Opt_Config_Switches (Save_Config_Switches); + + -- Deal with restore of restrictions + + Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions); + Expander_Mode_Restore; if Debug_Unit_Walk then diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index ae7edbf9dc2..c2277851bc4 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -841,13 +841,8 @@ package body Sem_Attr is and then not In_Instance and then not In_Inlined_Body then - if Restriction_Check_Required (No_Implicit_Aliasing) then - Error_Attr_P - ("prefix of % attribute must be explicitly aliased"); - else - Error_Attr_P - ("prefix of % attribute must be aliased"); - end if; + Error_Attr_P ("prefix of % attribute must be aliased"); + Check_No_Implicit_Aliasing (P); end if; end Analyze_Access_Attribute; @@ -2245,6 +2240,8 @@ package body Sem_Attr is if Restriction_Check_Required (No_Implicit_Aliasing) then if not Is_Aliased_View (P) then Check_Restriction (No_Implicit_Aliasing, P); + else + Check_No_Implicit_Aliasing (P); end if; end if; @@ -7824,14 +7821,30 @@ package body Sem_Attr is T := T / 10; end loop; + -- User declared enum type with discard names + + elsif Discard_Names (R) then + + -- If range is null, result is zero, that has already + -- been dealt with, so what we need is the power of ten + -- that accomodates the Pos of the largest value, which + -- is the high bound of the range + one for the space. + + W := 1; + T := Hi; + while T /= 0 loop + T := T / 10; + W := W + 1; + end loop; + -- Only remaining possibility is user declared enum type + -- with normal case of Discard_Names not active. else pragma Assert (Is_Enumeration_Type (P_Type)); W := 0; L := First_Literal (P_Type); - while Present (L) loop -- Only pay attention to in range characters @@ -8645,13 +8658,14 @@ package body Sem_Attr is end if; end if; - -- Check the static accessibility rule of 3.10.2(28). - -- Note that this check is not performed for the - -- case of an anonymous access type, since the access - -- attribute is always legal in such a context. + -- Check the static accessibility rule of 3.10.2(28). Note that + -- this check is not performed for the case of an anonymous + -- access type, since the access attribute is always legal + -- in such a context. if Attr_Id /= Attribute_Unchecked_Access - and then Object_Access_Level (P) > Type_Access_Level (Btyp) + and then + Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) and then Ekind (Btyp) = E_General_Access_Type then Accessibility_Message; @@ -8673,7 +8687,7 @@ package body Sem_Attr is -- anonymous_access_to_protected, there are no accessibility -- checks either. Omit check entirely for Unrestricted_Access. - elsif Object_Access_Level (P) > Type_Access_Level (Btyp) + elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp) and then Comes_From_Source (N) and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type and then Attr_Id /= Attribute_Unrestricted_Access diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 34346e39925..e5afc1b8b2f 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -467,7 +467,6 @@ package body Sem_Ch10 is -- generated with clauses or limited with clauses. Note that -- we examine with clauses having pragmas Elaborate or -- Elaborate_All applied to them due to cases such as: - -- -- with Pack; -- with Pack; @@ -725,7 +724,12 @@ package body Sem_Ch10 is return; else + -- Analyze the package spec + Semantics (Lib_Unit); + + -- Check for unused with's + Check_Unused_Withs (Get_Cunit_Unit_Number (Lib_Unit)); -- Verify that the library unit is a package declaration @@ -857,8 +861,6 @@ package body Sem_Ch10 is declare Save_Style_Check : constant Boolean := Style_Check; - Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := - Cunit_Boolean_Restrictions_Save; begin if not GNAT_Mode then @@ -867,8 +869,10 @@ package body Sem_Ch10 is Semantics (Parent_Spec (Unit_Node)); Version_Update (N, Parent_Spec (Unit_Node)); + + -- Restore style check settings + Style_Check := Save_Style_Check; - Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); end; end if; @@ -1052,8 +1056,6 @@ package body Sem_Ch10 is Un : Unit_Number_Type; Save_Style_Check : constant Boolean := Style_Check; - Save_C_Restrict : constant Save_Cunit_Boolean_Restrictions := - Cunit_Boolean_Restrictions_Save; begin Item := First (Context_Items (N)); @@ -1122,8 +1124,9 @@ package body Sem_Ch10 is Next (Item); end loop; + -- Restore style checks settings + Style_Check := Save_Style_Check; - Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); end; end if; @@ -1641,7 +1644,7 @@ package body Sem_Ch10 is -- subunit, and that the current unit is one of its parents which was -- being analyzed to provide the needed context for the analysis of the -- subunit. In this case we analyze the subunit and continue with the - -- parent, without looking a subsequent subunits. + -- parent, without looking at subsequent subunits. if Is_Loaded (Subunit_Name) then @@ -2351,7 +2354,6 @@ package body Sem_Ch10 is -- warnings if we have this definite error. Save_Style_Check : constant Boolean := Opt.Style_Check; - Save_C_Restrict : Save_Cunit_Boolean_Restrictions; begin U := Unit (Library_Unit (N)); @@ -2388,10 +2390,6 @@ package body Sem_Ch10 is end if; end if; - -- Save current restriction set, does not apply to with'ed unit - - Save_C_Restrict := Cunit_Boolean_Restrictions_Save; - -- Several actions are skipped for dummy packages (those supplied for -- with's where no matching file could be found). Such packages are -- identified by the Sloc value being set to No_Location. @@ -2591,10 +2589,9 @@ package body Sem_Ch10 is end if; end if; - -- Restore style checks and restrictions + -- Restore style checks Style_Check := Save_Style_Check; - Cunit_Boolean_Restrictions_Restore (Save_C_Restrict); -- Record the reference, but do NOT set the unit as referenced, we want -- to consider the unit as unreferenced if this is the only reference diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index e51b8029803..2a431f8635e 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5076,6 +5076,18 @@ package body Sem_Ch12 is then null; + -- If the formal package has an "others" box association that + -- covers this formal, there is no need for a check either. + + elsif Nkind (Unit_Declaration_Node (E2)) in + N_Formal_Subprogram_Declaration + and then Box_Present (Unit_Declaration_Node (E2)) + then + null; + + -- Otherwise the actual in the formal and the actual in the + -- instantiation of the formal must match, up to renamings. + else Check_Mismatch (Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); @@ -12383,9 +12395,11 @@ package body Sem_Ch12 is procedure Reset_Entity (N : Node_Id) is procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); - -- If the type of N2 is global to the generic unit. Save the type in - -- the generic node. - -- What does this comment mean??? + -- If the type of N2 is global to the generic unit, save the type in + -- the generic node. Just as we perform name capture for explicit + -- references within the generic, we must capture the global types + -- of local entities because they may participate in resolution in + -- the instance. function Top_Ancestor (E : Entity_Id) return Entity_Id; -- Find the ultimate ancestor of the current unit. If it is not a diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index acfb989dc3c..7de3c164ede 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -161,15 +161,15 @@ package body Sem_Ch13 is ---------------------------------------------- -- The following table collects unchecked conversions for validation. - -- Entries are made by Validate_Unchecked_Conversion and then the - -- call to Validate_Unchecked_Conversions does the actual error - -- checking and posting of warnings. The reason for this delayed - -- processing is to take advantage of back-annotations of size and - -- alignment values performed by the back end. + -- Entries are made by Validate_Unchecked_Conversion and then the call + -- to Validate_Unchecked_Conversions does the actual error checking and + -- posting of warnings. The reason for this delayed processing is to take + -- advantage of back-annotations of size and alignment values performed by + -- the back end. - -- Note: the reason we store a Source_Ptr value instead of a Node_Id - -- is that by the time Validate_Unchecked_Conversions is called, Sprint - -- will already have modified all Sloc values if the -gnatD option is set. + -- Note: the reason we store a Source_Ptr value instead of a Node_Id is + -- that by the time Validate_Unchecked_Conversions is called, Sprint will + -- already have modified all Sloc values if the -gnatD option is set. type UC_Entry is record Eloc : Source_Ptr; -- node used for posting warnings @@ -193,13 +193,13 @@ package body Sem_Ch13 is -- for X'Address use Expr - -- where Expr is of the form Y'Address or recursively is a reference - -- to a constant of either of these forms, and X and Y are entities of - -- objects, then if Y has a smaller alignment than X, that merits a - -- warning about possible bad alignment. The following table collects - -- address clauses of this kind. We put these in a table so that they - -- can be checked after the back end has completed annotation of the - -- alignments of objects, since we can catch more cases that way. + -- where Expr is of the form Y'Address or recursively is a reference to a + -- constant of either of these forms, and X and Y are entities of objects, + -- then if Y has a smaller alignment than X, that merits a warning about + -- possible bad alignment. The following table collects address clauses of + -- this kind. We put these in a table so that they can be checked after the + -- back end has completed annotation of the alignments of objects, since we + -- can catch more cases that way. type Address_Clause_Check_Record is record N : Node_Id; @@ -728,8 +728,9 @@ package body Sem_Ch13 is A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); Anod : Node_Id; - Eloc : Source_Ptr := Sloc (Expr); - -- Source location of expression, modified when we split PPC's + Eloc : Source_Ptr := No_Location; + -- Source location of expression, modified when we split PPC's. It + -- is set below when Expr is present. procedure Check_False_Aspect_For_Derived_Type; -- This procedure checks for the case of a false aspect for a @@ -804,6 +805,18 @@ package body Sem_Ch13 is goto Continue; end if; + -- Set the source location of expression, used in the case of + -- a failed precondition/postcondition or invariant. Note that + -- the source location of the expression is not usually the best + -- choice here. For example, it gets located on the last AND + -- keyword in a chain of boolean expressiond AND'ed together. + -- It is best to put the message on the first character of the + -- assertion, which is the effect of the First_Node call here. + + if Present (Expr) then + Eloc := Sloc (First_Node (Expr)); + end if; + -- Check restriction No_Implementation_Aspect_Specifications if Impl_Defined_Aspects (A_Id) then @@ -8605,8 +8618,8 @@ package body Sem_Ch13 is Target := Ancestor_Subtype (Etype (Act_Unit)); -- If either type is generic, the instantiation happens within a generic - -- unit, and there is nothing to check. The proper check - -- will happen when the enclosing generic is instantiated. + -- unit, and there is nothing to check. The proper check will happen + -- when the enclosing generic is instantiated. if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then return; @@ -8704,9 +8717,8 @@ package body Sem_Ch13 is end if; -- If unchecked conversion to access type, and access type is declared - -- in the same unit as the unchecked conversion, then set the - -- No_Strict_Aliasing flag (no strict aliasing is implicit in this - -- situation). + -- in the same unit as the unchecked conversion, then set the flag + -- No_Strict_Aliasing (no strict aliasing is implicit here) if Is_Access_Type (Target) and then In_Same_Source_Unit (Target, N) @@ -8714,11 +8726,11 @@ package body Sem_Ch13 is Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); end if; - -- Generate N_Validate_Unchecked_Conversion node for back end in - -- case the back end needs to perform special validation checks. + -- Generate N_Validate_Unchecked_Conversion node for back end in case + -- the back end needs to perform special validation checks. - -- Shouldn't this be in Exp_Ch13, since the check only gets done - -- if we have full expansion and the back end is called ??? + -- Shouldn't this be in Exp_Ch13, since the check only gets done if we + -- have full expansion and the back end is called ??? Vnode := Make_Validate_Unchecked_Conversion (Sloc (N)); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 488e6dc98cc..5cc06e7d899 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -726,13 +726,33 @@ package body Sem_Ch3 is -- If the access definition is the return type of another access to -- function, scope is the current one, because it is the one of the - -- current type declaration. + -- current type declaration, except for the pathological case below. if Nkind_In (Related_Nod, N_Object_Declaration, N_Access_Function_Definition) then Anon_Scope := Current_Scope; + -- A pathological case: function returning access functions that + -- return access functions, etc. Each anonymous access type created + -- is in the enclosing scope of the outermost function. + + declare + Par : Node_Id; + + begin + Par := Related_Nod; + while Nkind_In (Par, N_Access_Function_Definition, + N_Access_Definition) + loop + Par := Parent (Par); + end loop; + + if Nkind (Par) = N_Function_Specification then + Anon_Scope := Scope (Defining_Entity (Par)); + end if; + end; + -- For the anonymous function result case, retrieve the scope of the -- function specification's associated entity rather than using the -- current scope. The current scope will be the function itself if the @@ -1876,7 +1896,9 @@ package body Sem_Ch3 is -- (Ada 2005: AI-230): Accessibility check for anonymous -- components - if Type_Access_Level (Etype (E)) > Type_Access_Level (T) then + if Type_Access_Level (Etype (E)) > + Deepest_Type_Access_Level (T) + then Error_Msg_N ("expression has deeper access level than component " & "(RM 3.10.2 (12.2))", E); @@ -2664,8 +2686,8 @@ package body Sem_Ch3 is -- Process expression, replacing error by integer zero, to avoid -- cascaded errors or aborts further along in the processing - -- Replace Error by integer zero, which seems least likely to - -- cause cascaded errors. + -- Replace Error by integer zero, which seems least likely to cause + -- cascaded errors. if E = Error then Rewrite (E, Make_Integer_Literal (Sloc (E), Uint_0)); @@ -4042,6 +4064,19 @@ package body Sem_Ch3 is T := Process_Subtype (Subtype_Indication (N), N, Id, 'P'); + -- Class-wide equivalent types of records with unknown discriminants + -- involve the generation of an itype which serves as the private view + -- of a constrained record subtype. In such cases the base type of the + -- current subtype we are processing is the private itype. Use the full + -- of the private itype when decorating various attributes. + + if Is_Itype (T) + and then Is_Private_Type (T) + and then Present (Full_View (T)) + then + T := Full_View (T); + end if; + -- Inherit common attributes Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T))); @@ -11764,6 +11799,11 @@ package body Sem_Ch3 is -- needed, since checks may cause duplication of the expressions -- which must not be reevaluated. + -- The forced evaluation removes side effects from expressions, + -- which should occur also in Alfa mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. + if Expander_Active then Force_Evaluation (Low_Bound (R)); Force_Evaluation (High_Bound (R)); @@ -18304,6 +18344,11 @@ package body Sem_Ch3 is -- if needed, before applying checks, since checks may cause -- duplication of the expression without forcing evaluation. + -- The forced evaluation removes side effects from expressions, + -- which should occur also in Alfa mode. Otherwise, we end up with + -- unexpected insertions of actions at places where this is not + -- supposed to occur, e.g. on default parameters of a call. + if Expander_Active then Force_Evaluation (Lo); Force_Evaluation (Hi); @@ -18414,6 +18459,11 @@ package body Sem_Ch3 is -- Case of other than an explicit N_Range node + -- The forced evaluation removes side effects from expressions, which + -- should occur also in Alfa mode. Otherwise, we end up with unexpected + -- insertions of actions at places where this is not supposed to occur, + -- e.g. on default parameters of a call. + elsif Expander_Active then Get_Index_Bounds (R, Lo, Hi); Force_Evaluation (Lo); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 4b438e13f1c..0f918c06b4c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3432,8 +3432,8 @@ package body Sem_Ch4 is -- of the high bound. procedure Check_Universal_Expression (N : Node_Id); - -- In Ada83, reject bounds of a universal range that are not literals or - -- entity names. + -- In Ada 83, reject bounds of a universal range that are not literals + -- or entity names. ----------------------- -- Check_Common_Type -- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 0e6c5cf98bd..073bc2b840a 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -75,6 +75,14 @@ package body Sem_Ch5 is -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. + procedure Pre_Analyze_Range (R_Copy : Node_Id); + -- Determine expected type of range or domain of iteration of Ada 2012 + -- loop by analyzing separate copy. Do the analysis and resolution of the + -- copy of the bound(s) with expansion disabled, to prevent the generation + -- of finalization actions. This prevents memory leaks when the bounds + -- contain calls to functions returning controlled arrays or when the + -- domain of iteration is a container. + ------------------------ -- Analyze_Assignment -- ------------------------ @@ -1618,90 +1626,6 @@ package body Sem_Ch5 is -- calls that use the secondary stack, returning True if any such call -- is found, and False otherwise. - procedure Pre_Analyze_Range (R_Copy : Node_Id); - -- Determine expected type of range or domain of iteration of Ada 2012 - -- loop by analyzing separate copy. Do the analysis and resolution of - -- the copy of the bound(s) with expansion disabled, to prevent the - -- generation of finalization actions. This prevents memory leaks when - -- the bounds contain calls to functions returning controlled arrays or - -- when the domain of iteration is a container. - - ----------------------- - -- Pre_Analyze_Range -- - ----------------------- - - procedure Pre_Analyze_Range (R_Copy : Node_Id) is - Save_Analysis : Boolean; - begin - Save_Analysis := Full_Analysis; - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - Analyze (R_Copy); - - if Nkind (R_Copy) in N_Subexpr - and then Is_Overloaded (R_Copy) - then - - -- Apply preference rules for range of predefined integer types, - -- or diagnose true ambiguity. - - declare - I : Interp_Index; - It : Interp; - Found : Entity_Id := Empty; - - begin - Get_First_Interp (R_Copy, I, It); - while Present (It.Typ) loop - if Is_Discrete_Type (It.Typ) then - if No (Found) then - Found := It.Typ; - else - if Scope (Found) = Standard_Standard then - null; - - elsif Scope (It.Typ) = Standard_Standard then - Found := It.Typ; - - else - -- Both of them are user-defined - - Error_Msg_N - ("ambiguous bounds in range of iteration", - R_Copy); - Error_Msg_N ("\possible interpretations:", R_Copy); - Error_Msg_NE ("\\} ", R_Copy, Found); - Error_Msg_NE ("\\} ", R_Copy, It.Typ); - exit; - end if; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - if Is_Entity_Name (R_Copy) - and then Is_Type (Entity (R_Copy)) - then - - -- Subtype mark in iteration scheme - - null; - - elsif Nkind (R_Copy) in N_Subexpr then - - -- Expression in range, or Ada 2012 iterator - - Resolve (R_Copy); - end if; - - Expander_Mode_Restore; - Full_Analysis := Save_Analysis; - end Pre_Analyze_Range; - -------------------- -- Process_Bounds -- -------------------- @@ -1855,7 +1779,7 @@ package body Sem_Ch5 is if New_Lo_Bound /= Lo and then Is_Static_Expression (New_Lo_Bound) then - Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); + Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); end if; if New_Hi_Bound /= Hi @@ -2034,7 +1958,7 @@ package body Sem_Ch5 is begin if Present (H) and then Enclosing_Dynamic_Scope (H) = - Enclosing_Dynamic_Scope (Id) + Enclosing_Dynamic_Scope (Id) and then Ekind (H) = E_Variable and then Is_Discrete_Type (Etype (H)) then @@ -2059,7 +1983,7 @@ package body Sem_Ch5 is then Process_Bounds (DS); - -- expander not active or else range of iteration is a subtype + -- Expander not active or else range of iteration is a subtype -- indication, an entity, or a function call that yields an -- aggregate or a container. @@ -2513,12 +2437,95 @@ package body Sem_Ch5 is ---------------------------- procedure Analyze_Loop_Statement (N : Node_Id) is - Loop_Statement : constant Node_Id := N; - Id : constant Node_Id := Identifier (Loop_Statement); - Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); + function Is_Container_Iterator (Iter : Node_Id) return Boolean; + -- Given a loop iteration scheme, determine whether it is an Ada 2012 + -- container iteration. + + function Is_Wrapped_In_Block (N : Node_Id) return Boolean; + -- Determine whether node N is the sole statement of a block + + --------------------------- + -- Is_Container_Iterator -- + --------------------------- + + function Is_Container_Iterator (Iter : Node_Id) return Boolean is + begin + -- Infinite loop + + if No (Iter) then + return False; + + -- While loop + + elsif Present (Condition (Iter)) then + return False; + + -- for Def_Id in [reverse] Name loop + -- for Def_Id [: Subtype_Indication] of [reverse] Name loop + + elsif Present (Iterator_Specification (Iter)) then + declare + Nam : constant Node_Id := Name (Iterator_Specification (Iter)); + Nam_Copy : Node_Id; + + begin + Nam_Copy := New_Copy_Tree (Nam); + Set_Parent (Nam_Copy, Parent (Nam)); + Pre_Analyze_Range (Nam_Copy); + + -- The only two options here are iteration over a container or + -- an array. + + return not Is_Array_Type (Etype (Nam_Copy)); + end; + + -- for Def_Id in [reverse] Discrete_Subtype_Definition loop + + else + declare + LP : constant Node_Id := Loop_Parameter_Specification (Iter); + DS : constant Node_Id := Discrete_Subtype_Definition (LP); + DS_Copy : Node_Id; + + begin + DS_Copy := New_Copy_Tree (DS); + Set_Parent (DS_Copy, Parent (DS)); + Pre_Analyze_Range (DS_Copy); + + -- Check for a call to Iterate () + + return + Nkind (DS_Copy) = N_Function_Call + and then Needs_Finalization (Etype (DS_Copy)); + end; + end if; + end Is_Container_Iterator; + + ------------------------- + -- Is_Wrapped_In_Block -- + ------------------------- + + function Is_Wrapped_In_Block (N : Node_Id) return Boolean is + HSS : constant Node_Id := Parent (N); + + begin + return + Nkind (HSS) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (HSS)) = N_Block_Statement + and then First (Statements (HSS)) = N + and then No (Next (First (Statements (HSS)))); + end Is_Wrapped_In_Block; + + -- Local declarations + + Id : constant Node_Id := Identifier (N); + Iter : constant Node_Id := Iteration_Scheme (N); + Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; + -- Start of processing for Analyze_Loop_Statement + begin if Present (Id) then @@ -2534,15 +2541,13 @@ package body Sem_Ch5 is if No (Ent) then if Total_Errors_Detected /= 0 then - Ent := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); + Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); else raise Program_Error; end if; else - Generate_Reference (Ent, Loop_Statement, ' '); + Generate_Reference (Ent, N, ' '); Generate_Definition (Ent); -- If we found a label, mark its type. If not, ignore it, since it @@ -2555,7 +2560,7 @@ package body Sem_Ch5 is Set_Ekind (Ent, E_Loop); if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then - Set_Label_Construct (Parent (Ent), Loop_Statement); + Set_Label_Construct (Parent (Ent), N); end if; end if; end if; @@ -2563,11 +2568,28 @@ package body Sem_Ch5 is -- Case of no identifier present else - Ent := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L'); - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, Loop_Statement); + Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L'); + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, N); + end if; + + -- Iteration over a container in Ada 2012 involves the creation of a + -- controlled iterator object. Wrap the loop in a block to ensure the + -- timely finalization of the iterator and release of container locks. + + if Ada_Version >= Ada_2012 + and then Is_Container_Iterator (Iter) + and then not Is_Wrapped_In_Block (N) + then + Rewrite (N, + Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Relocate_Node (N))))); + + Analyze (N); + return; end if; -- Kill current values on entry to loop, since statements in the body of @@ -2610,7 +2632,7 @@ package body Sem_Ch5 is end; end if; - Analyze_Statements (Statements (Loop_Statement)); + Analyze_Statements (Statements (N)); end if; -- Finish up processing for the loop. We kill all current values, since @@ -2619,7 +2641,7 @@ package body Sem_Ch5 is -- know will execute at least once, but it's not worth the trouble and -- the front end is not in the business of flow tracing. - Process_End_Label (Loop_Statement, 'e', Ent); + Process_End_Label (N, 'e', Ent); End_Scope; Kill_Current_Values; @@ -2871,4 +2893,76 @@ package body Sem_Ch5 is end if; end Check_Unreachable_Code; + ----------------------- + -- Pre_Analyze_Range -- + ----------------------- + + procedure Pre_Analyze_Range (R_Copy : Node_Id) is + Save_Analysis : constant Boolean := Full_Analysis; + + begin + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (R_Copy); + + if Nkind (R_Copy) in N_Subexpr + and then Is_Overloaded (R_Copy) + then + -- Apply preference rules for range of predefined integer types, or + -- diagnose true ambiguity. + + declare + I : Interp_Index; + It : Interp; + Found : Entity_Id := Empty; + + begin + Get_First_Interp (R_Copy, I, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + if No (Found) then + Found := It.Typ; + else + if Scope (Found) = Standard_Standard then + null; + + elsif Scope (It.Typ) = Standard_Standard then + Found := It.Typ; + + else + -- Both of them are user-defined + + Error_Msg_N + ("ambiguous bounds in range of iteration", R_Copy); + Error_Msg_N ("\possible interpretations:", R_Copy); + Error_Msg_NE ("\\} ", R_Copy, Found); + Error_Msg_NE ("\\} ", R_Copy, It.Typ); + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + -- Subtype mark in iteration scheme + + if Is_Entity_Name (R_Copy) + and then Is_Type (Entity (R_Copy)) + then + null; + + -- Expression in range, or Ada 2012 iterator + + elsif Nkind (R_Copy) in N_Subexpr then + Resolve (R_Copy); + end if; + + Expander_Mode_Restore; + Full_Analysis := Save_Analysis; + end Pre_Analyze_Range; + end Sem_Ch5; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a9f84d34faa..780a916bc2d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -268,14 +268,19 @@ package body Sem_Ch6 is procedure Analyze_Expression_Function (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); LocX : constant Source_Ptr := Sloc (Expression (N)); - Def_Id : constant Entity_Id := Defining_Entity (Specification (N)); Expr : constant Node_Id := Expression (N); - New_Body : Node_Id; - New_Decl : Node_Id; + Spec : constant Node_Id := Specification (N); - Prev : constant Entity_Id := Current_Entity_In_Scope (Def_Id); + Def_Id : Entity_Id; + pragma Unreferenced (Def_Id); + + Prev : Entity_Id; -- If the expression is a completion, Prev is the entity whose - -- declaration is completed. + -- declaration is completed. Def_Id is needed to analyze the spec. + + New_Body : Node_Id; + New_Decl : Node_Id; + New_Spec : Node_Id; begin -- This is one of the occasions on which we transform the tree during @@ -286,10 +291,20 @@ package body Sem_Ch6 is -- determine whether this is possible. Inline_Processing_Required := True; + New_Spec := Copy_Separate_Tree (Spec); + Prev := Current_Entity_In_Scope (Defining_Entity (Spec)); + + -- If there are previous overloadable entities with the same name, + -- check whether any of them is completed by the expression function. + + if Present (Prev) and then Is_Overloadable (Prev) then + Def_Id := Analyze_Subprogram_Specification (Spec); + Prev := Find_Corresponding_Spec (N); + end if; New_Body := Make_Subprogram_Body (Loc, - Specification => Copy_Separate_Tree (Specification (N)), + Specification => New_Spec, Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (LocX, @@ -307,6 +322,7 @@ package body Sem_Ch6 is Insert_After (N, New_Body); Rewrite (N, Make_Null_Statement (Loc)); + Set_Has_Completion (Prev, False); Analyze (N); Analyze (New_Body); Set_Is_Inlined (Prev); @@ -314,6 +330,7 @@ package body Sem_Ch6 is elsif Present (Prev) and then Comes_From_Source (Prev) then + Set_Has_Completion (Prev, False); Rewrite (N, New_Body); Analyze (N); @@ -333,8 +350,7 @@ package body Sem_Ch6 is else New_Decl := - Make_Subprogram_Declaration (Loc, - Specification => Specification (N)); + Make_Subprogram_Declaration (Loc, Specification => Spec); Rewrite (N, New_Decl); Analyze (N); @@ -1469,9 +1485,19 @@ package body Sem_Ch6 is -- extended_return_statement. if Returns_Object then - Error_Msg_N - ("extended_return_statement cannot return value; " & - "use `""RETURN;""`", N); + if Nkind (N) = N_Extended_Return_Statement then + Error_Msg_N + ("extended return statements cannot be nested; use `RETURN;`", + N); + + -- Case of a simple return statement with a value inside extended + -- return statement. + + else + Error_Msg_N + ("return nested in extended return statement cannot return " & + "value; use `RETURN;`", N); + end if; end if; else @@ -8536,19 +8562,19 @@ package body Sem_Ch6 is and then In_Private_Part (Current_Scope) then Priv_Decls := - Private_Declarations ( - Specification (Unit_Declaration_Node (Current_Scope))); + Private_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))); return In_Package_Body (Current_Scope) or else (Is_List_Member (Decl) - and then List_Containing (Decl) = Priv_Decls) + and then List_Containing (Decl) = Priv_Decls) or else (Nkind (Parent (Decl)) = N_Package_Specification - and then not - Is_Compilation_Unit - (Defining_Entity (Parent (Decl))) - and then List_Containing (Parent (Parent (Decl))) - = Priv_Decls); + and then not + Is_Compilation_Unit + (Defining_Entity (Parent (Decl))) + and then List_Containing (Parent (Parent (Decl))) = + Priv_Decls); else return False; end if; @@ -9562,6 +9588,15 @@ package body Sem_Ch6 is -- or IN OUT parameters of the subprogram, or (for a function) if the -- return value has an invariant. + function Is_Public_Subprogram_For (T : Entity_Id) return Boolean; + -- T is the entity for a private type for which invariants are defined. + -- This function returns True if the procedure corresponding to the + -- value of Designator is a public procedure from the point of view of + -- this type (i.e. its spec is in the visible part of the package that + -- contains the declaration of the private type). A True value means + -- that an invariant check is required (for an IN OUT parameter, or + -- the returned value of a function. + -------------- -- Grab_PPC -- -------------- @@ -9689,6 +9724,45 @@ package body Sem_Ch6 is return False; end Invariants_Or_Predicates_Present; + ------------------------------ + -- Is_Public_Subprogram_For -- + ------------------------------ + + -- The type T is a private type, its declaration is therefore in + -- the list of public declarations of some package. The test for a + -- public subprogram is that its declaration is in this same list + -- of declarations for the same package (note that all the public + -- declarations are in one list, and all the private declarations + -- in another, so this deals with the public/private distinction). + + function Is_Public_Subprogram_For (T : Entity_Id) return Boolean is + DD : constant Node_Id := Unit_Declaration_Node (Designator); + -- The subprogram declaration for the subprogram in question + + TL : constant List_Id := + Visible_Declarations + (Specification (Unit_Declaration_Node (Scope (T)))); + -- The list of declarations containing the private declaration of + -- the type. We know it is a private type, so we know its scope is + -- the package in question, and we know it must be in the visible + -- declarations of this package. + + begin + -- If the subprogram declaration is not a list member, it must be + -- an Init_Proc, in which case we want to consider it to be a + -- public subprogram, since we do get initializations to deal with. + + if not Is_List_Member (DD) then + return True; + + -- Otherwise we test whether the subprogram is declared in the + -- visible declarations of the package containing the type. + + else + return TL = List_Containing (DD); + end if; + end Is_Public_Subprogram_For; + -- Start of processing for Process_PPCs begin @@ -9985,10 +10059,13 @@ package body Sem_Ch6 is Parameter_Type => New_Occurrence_Of (Ftyp, Loc), Defining_Identifier => Rent)); - -- Add invariant call if returning type with invariants + -- Add invariant call if returning type with invariants and + -- this is a public function, i.e. a function declared in the + -- visible part of the package defining the private type. if Has_Invariants (Etype (Rent)) and then Present (Invariant_Procedure (Etype (Rent))) + and then Is_Public_Subprogram_For (Etype (Rent)) then Append_To (Plist, Make_Invariant_Call (New_Occurrence_Of (Rent, Loc))); @@ -10017,6 +10094,7 @@ package body Sem_Ch6 is if Has_Invariants (Ftype) and then Present (Invariant_Procedure (Ftype)) + and then Is_Public_Subprogram_For (Ftype) then Append_To (Plist, Make_Invariant_Call diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 17f802fc14e..98913dbccce 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -52,6 +52,7 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; @@ -2848,6 +2849,13 @@ package body Sem_Ch8 is ("?redundant renaming, entity is directly visible", Name (N)); end if; + -- Implementation-defined aspect specifications can appear in a renaming + -- declaration, but not language-defined ones. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, New_S); + end if; + Ada_Version := Save_AV; Ada_Version_Explicit := Save_AV_Exp; end Analyze_Subprogram_Renaming; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 4b284cd9599..35c4eeebda0 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -905,6 +905,83 @@ package body Sem_Ch9 is Bad_Predicated_Subtype_Use ("subtype& has predicate, not allowed in entry family", D_Sdef, Etype (D_Sdef)); + + -- Check entry family static bounds outside allowed limits + + -- Note: originally this check was not performed here, but in that + -- case the check happens deep in the expander, and the message is + -- posted at the wrong location, and omitted in -gnatc mode. + -- If the type of the entry index is a generic formal, no check + -- is possible. In an instance, the check is not static and a run- + -- time exception will be raised if the bounds are unreasonable. + + declare + PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); + LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); + UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); + + LBR : Node_Id; + UBR : Node_Id; + + begin + + -- No bounds checking if the type is generic or if previous error. + -- In an instance the check is dynamic. + + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + or else Error_Posted (D_Sdef) + then + goto Skip_LB; + + elsif Nkind (D_Sdef) = N_Range then + LBR := Low_Bound (D_Sdef); + + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + LBR := Type_Low_Bound (Entity (D_Sdef)); + + else + goto Skip_LB; + end if; + + if Is_Static_Expression (LBR) + and then Expr_Value (LBR) < LB + then + Error_Msg_Uint_1 := LB; + Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); + end if; + + <<Skip_LB>> + if Is_Generic_Type (Etype (D_Sdef)) + or else In_Instance + or else Error_Posted (D_Sdef) + then + goto Skip_UB; + + elsif Nkind (D_Sdef) = N_Range then + UBR := High_Bound (D_Sdef); + + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + UBR := Type_High_Bound (Entity (D_Sdef)); + + else + goto Skip_UB; + end if; + + if Is_Static_Expression (UBR) + and then Expr_Value (UBR) > UB + then + Error_Msg_Uint_1 := UB; + Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); + end if; + + <<Skip_UB>> + null; + end; end if; -- Decorate Def_Id diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 5df43afc43e..ce4cff39d92 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2130,7 +2130,32 @@ package body Sem_Elab is end if; -- Here is the case of calling a subprogram where the body has not yet - -- been encountered, a warning message is needed. + -- been encountered. A warning message is needed, except if this is the + -- case of appearing within an aspect specification that results in + -- a check call, we do not really have such a situation, so no warning + -- is needed (e.g. the case of a precondition, where the call appears + -- textually before the body, but in actual fact is moved to the + -- appropriate subprogram body and so does not need a check). + + declare + P : Node_Id; + begin + P := Parent (N); + loop + if Nkind (P) in N_Subexpr then + P := Parent (P); + elsif Nkind (P) = N_If_Statement + and then Nkind (Original_Node (P)) = N_Pragma + and then Present (Corresponding_Aspect (Original_Node (P))) + then + return; + else + exit; + end if; + end loop; + end; + + -- Not that special case, warning and dynamic check is required -- If we have nothing in the call stack, then this is at the outer -- level, and the ABE is bound to occur. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 397c73380a2..a21358bd791 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3524,19 +3524,39 @@ package body Sem_Prag is ("second argument of pragma% must be a subprogram", Arg2); end if; - -- For Stdcall, a subprogram, variable or subprogram type is required + -- Stdcall case - if C = Convention_Stdcall - and then not Is_Subprogram (E) - and then not Is_Generic_Subprogram (E) - and then Ekind (E) /= E_Variable - and then not - (Is_Access_Type (E) - and then Ekind (Designated_Type (E)) = E_Subprogram_Type) - then - Error_Pragma_Arg - ("second argument of pragma% must be subprogram (type)", - Arg2); + if C = Convention_Stdcall then + + -- A dispatching call is not allowed. A dispatching subprogram + -- cannot be used to interface to the Win32 API, so in fact this + -- check does not impose any effective restriction. + + if Is_Dispatching_Operation (E) then + + Error_Pragma + ("dispatching subprograms cannot use Stdcall convention"); + + -- Subprogram is allowed, but not a generic subprogram, and not a + -- dispatching operation. + + elsif not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) + + -- A variable is OK + + and then Ekind (E) /= E_Variable + + -- An access to subprogram is also allowed + + and then not + (Is_Access_Type (E) + and then Ekind (Designated_Type (E)) = E_Subprogram_Type) + then + Error_Pragma_Arg + ("second argument of pragma% must be subprogram (type)", + Arg2); + end if; end if; if not Is_Subprogram (E) @@ -5337,6 +5357,46 @@ package body Sem_Prag is Check_Restriction (No_Implementation_Restrictions, Arg); end if; + -- Special processing for No_Elaboration_Code restriction + + if R_Id = No_Elaboration_Code then + + -- Restriction is only recognized within a configuration + -- pragma file, or within a unit of the main extended + -- program. Note: the test for Main_Unit is needed to + -- properly include the case of configuration pragma files. + + if not (Current_Sem_Unit = Main_Unit + or else In_Extended_Main_Source_Unit (N)) + then + return; + + -- Don't allow in a subunit unless already specified in + -- body or spec. + + elsif Nkind (Parent (N)) = N_Compilation_Unit + and then Nkind (Unit (Parent (N))) = N_Subunit + and then not Restriction_Active (No_Elaboration_Code) + then + Error_Msg_N + ("invalid specification of ""No_Elaboration_Code""", + N); + Error_Msg_N + ("\restriction cannot be specified in a subunit", N); + Error_Msg_N + ("\unless also specified in body or spec", N); + return; + + -- If we have a No_Elaboration_Code pragma that we + -- accept, then it needs to be added to the configuration + -- restrcition set so that we get proper application to + -- other units in the main extended source as required. + + else + Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); + end if; + end if; + -- If this is a warning, then set the warning unless we already -- have a real restriction active (we never want a warning to -- override a real restriction). @@ -12647,6 +12707,47 @@ package body Sem_Prag is end if; end Pure_05; + ------------- + -- Pure_12 -- + ------------- + + -- pragma Pure_12 [(library_unit_NAME)]; + + -- This pragma is useable only in GNAT_Mode, where it is used like + -- pragma Pure but it is only effective in Ada 2012 mode (otherwise + -- it is ignored). It may be used after a pragma Preelaborate, in + -- which case it overrides the effect of the pragma Preelaborate. + -- This is used to implement AI05-0212 which recategorizes some + -- run-time packages in Ada 2012 mode. + + when Pragma_Pure_12 => Pure_12 : declare + Ent : Entity_Id; + + begin + GNAT_Pragma; + Check_Valid_Library_Unit_Pragma; + + if not GNAT_Mode then + Error_Pragma ("pragma% only available in GNAT mode"); + end if; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + -- 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_2012 in a predefined unit), we need to know the + -- explicit version set to know if this pragma is active. + + if Ada_Version_Explicit >= Ada_2012 then + Ent := Find_Lib_Unit_Name; + Set_Is_Preelaborated (Ent, False); + Set_Is_Pure (Ent); + Set_Suppress_Elaboration_Warnings (Ent); + end if; + end Pure_12; + ------------------- -- Pure_Function -- ------------------- @@ -14427,7 +14528,7 @@ package body Sem_Prag is end; end if; - -- Two or more arguments (must be two) + -- Two or more arguments (must be two) else Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); @@ -14446,8 +14547,7 @@ package body Sem_Prag is -- the formal may be wrapped in a conversion if the -- actual is a conversion. Retrieve the real entity name. - if (In_Instance_Body - or else In_Inlined_Body) + if (In_Instance_Body or else In_Inlined_Body) and then Nkind (E_Id) = N_Unchecked_Type_Conversion then E_Id := Expression (E_Id); @@ -14511,10 +14611,21 @@ package body Sem_Prag is -- In any other case, an error will be signalled (ON -- with no matching OFF). + -- Note: We set Used if we are inside a generic to + -- disable the test that the non-config case actually + -- cancels a warning. That's because we can't be sure + -- there isn't an instantiation in some other unit + -- where a warning is suppressed. + + -- We could do a little better here by checking if the + -- generic unit we are inside is public, but for now + -- we don't bother with that refinement. + if Chars (Argx) = Name_Off then Set_Specific_Warning_Off (Loc, Name_Buffer (1 .. Name_Len), - Config => Is_Configuration_Pragma); + Config => Is_Configuration_Pragma, + Used => Inside_A_Generic or else In_Instance); elsif Chars (Argx) = Name_On then Set_Specific_Warning_On @@ -14959,6 +15070,7 @@ package body Sem_Prag is Pragma_Psect_Object => -1, Pragma_Pure => -1, Pragma_Pure_05 => -1, + Pragma_Pure_12 => -1, Pragma_Pure_Function => -1, Pragma_Queuing_Policy => -1, Pragma_Ravenscar => -1, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ad59f952252..a240781dc8a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2811,7 +2811,7 @@ package body Sem_Res is -- default expression mode (the Freeze_Expression routine tests this -- flag and only freezes static types if it is set). - -- AI05-177 (Ada2012): Expression functions do not freeze. Only + -- Ada 2012 (AI05-177): Expression functions do not freeze. Only -- their use (in an expanded call) freezes. if Ekind (Current_Scope) /= E_Function @@ -4086,7 +4086,7 @@ package body Sem_Res is is begin if Type_Access_Level (Etype (Disc_Exp)) > - Type_Access_Level (Alloc_Typ) + Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N ("operand type has deeper level than allocator type", Disc_Exp); @@ -4095,10 +4095,10 @@ package body Sem_Res is -- object must not be deeper than that of the allocator's type. elsif Nkind (Disc_Exp) = N_Attribute_Reference - and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) - = Attribute_Access - and then Object_Access_Level (Prefix (Disc_Exp)) - > Type_Access_Level (Alloc_Typ) + and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) = + Attribute_Access + and then Object_Access_Level (Prefix (Disc_Exp)) > + Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N ("prefix of attribute has deeper level than allocator type", @@ -4109,8 +4109,8 @@ package body Sem_Res is elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type and then Nkind (Disc_Exp) = N_Selected_Component - and then Object_Access_Level (Prefix (Disc_Exp)) - > Type_Access_Level (Alloc_Typ) + and then Object_Access_Level (Prefix (Disc_Exp)) > + Deepest_Type_Access_Level (Alloc_Typ) then Error_Msg_N ("access discriminant has deeper level than allocator type", @@ -4314,7 +4314,9 @@ package body Sem_Res is Exp_Typ := Entity (E); end if; - if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then + if Type_Access_Level (Exp_Typ) > + Deepest_Type_Access_Level (Typ) + then if In_Instance_Body then Error_Msg_N ("?type in allocator has deeper level than" & " designated class-wide type", E); @@ -8666,7 +8668,15 @@ package body Sem_Res is -- this by making sure that the expanded code points to -- the Sloc of the expression, not the original pragma. - Error_Msg_N + -- Note: Use Error_Msg_F here rather than Error_Msg_N. + -- The source location of the expression is not usually + -- the best choice here. For example, it gets located on + -- the last AND keyword in a chain of boolean expressiond + -- AND'ed together. It is best to put the message on the + -- first character of the assertion, which is the effect + -- of the First_Node call here. + + Error_Msg_F ("?assertion would fail at run time!", Expression (First (Pragma_Argument_Associations (Orig)))); @@ -8691,8 +8701,14 @@ package body Sem_Res is and then Entity (Expr) = Standard_False then null; + + -- Post warning + else - Error_Msg_N + -- Again use Error_Msg_F rather than Error_Msg_N, see + -- comment above for an explanation of why we do this. + + Error_Msg_F ("?check would fail at run time!", Expression (Last (Pragma_Argument_Associations (Orig)))); @@ -10358,13 +10374,15 @@ package body Sem_Res is Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) then if Type_Access_Level (Target_Type) < - Type_Access_Level (Opnd_Type) + Deepest_Type_Access_Level (Opnd_Type) then if In_Instance_Body then - Error_Msg_N ("?source array type " & - "has deeper accessibility level than target", Operand); - Error_Msg_N ("\?Program_Error will be raised at run time", - Operand); + Error_Msg_N + ("?source array type has " & + "deeper accessibility level than target", Operand); + Error_Msg_N + ("\?Program_Error will be raised at run time", + Operand); Rewrite (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Accessibility_Check_Failed)); @@ -10374,8 +10392,9 @@ package body Sem_Res is -- Conversion not allowed because of accessibility levels else - Error_Msg_N ("source array type " & - "has deeper accessibility level than target", Operand); + Error_Msg_N + ("source array type has " & + "deeper accessibility level than target", Operand); return False; end if; @@ -10398,7 +10417,7 @@ package body Sem_Res is -- All of this is checked in Subtypes_Statically_Match. if not Subtypes_Statically_Match - (Target_Comp_Type, Opnd_Comp_Type) + (Target_Comp_Type, Opnd_Comp_Type) then Error_Msg_N ("component subtypes must statically match", Operand); @@ -11069,6 +11088,11 @@ package body Sem_Res is N); return True; + -- If it was legal in the generic, it's legal in the instance + + elsif In_Instance_Body then + return True; + -- If both are tagged types, check legality of view conversions elsif Is_Tagged_Type (Target_Type) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1764da9db02..edf1fecbfe6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2437,6 +2437,12 @@ package body Sem_Util is (Defining_Identifier (Associated_Node_For_Itype (Typ)))); + -- For generic formal type, return Int'Last (infinite). + -- See comment preceding Is_Generic_Type call in Type_Access_Level. + + elsif Is_Generic_Type (Root_Type (Typ)) then + return UI_From_Int (Int'Last); + else return Type_Access_Level (Typ); end if; @@ -6583,10 +6589,6 @@ package body Sem_Util is if Is_Entity_Name (Obj) then E := Entity (Obj); - if Is_Object (E) and then not Is_Aliased (E) then - Check_Restriction (No_Implicit_Aliasing, Obj); - end if; - return (Is_Object (E) and then @@ -8731,10 +8733,15 @@ package body Sem_Util is then return True; - elsif Nkind (N) = N_Indexed_Component - or else Nkind (N) = N_Selected_Component + elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) + and then Is_Volatile_Prefix (Prefix (N)) then - return Is_Volatile_Prefix (Prefix (N)); + return True; + + elsif Nkind (N) = N_Selected_Component + and then Is_Volatile (Entity (Selector_Name (N))) + then + return True; else return False; @@ -10837,9 +10844,7 @@ package body Sem_Util is -- source. This excludes, for example, calls to a dispatching -- assignment operation when the left-hand side is tagged. - if Modification_Comes_From_Source - or else Alfa_Mode - then + if Modification_Comes_From_Source or else Alfa_Mode then Generate_Reference (Ent, Exp, 'm'); -- If the target of the assignment is the bound variable @@ -12715,6 +12720,25 @@ package body Sem_Util is end if; end if; + -- Return library level for a generic formal type. This is done because + -- RM(10.3.2) says that "The statically deeper relationship does not + -- apply to ... a descendant of a generic formal type". Rather than + -- checking at each point where a static accessibility check is + -- performed to see if we are dealing with a formal type, this rule is + -- implemented by having Type_Access_Level and Deepest_Type_Access_Level + -- return extreme values for a formal type; Deepest_Type_Access_Level + -- returns Int'Last. By calling the appropriate function from among the + -- two, we ensure that the static accessibility check will pass if we + -- happen to run into a formal type. More specifically, we should call + -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the + -- call occurs as part of a static accessibility check and the error + -- case is the case where the type's level is too shallow (as opposed + -- to too deep). + + if Is_Generic_Type (Root_Type (Btyp)) then + return Scope_Depth (Standard_Standard); + end if; + return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c7f610d52f0..693ddf2def9 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -314,7 +314,9 @@ package Sem_Util is -- static accesssibility level of the object. In that case, the dynamic -- accessibility level of the object may take on values in a range. The low -- bound of of that range is returned by Type_Access_Level; this function - -- yields the high bound of that range. + -- yields the high bound of that range. Also differs from Type_Access_Level + -- in the case of a descendant of a generic formal type (returns Int'Last + -- instead of 0). function Defining_Entity (N : Node_Id) return Entity_Id; -- Given a declaration N, returns the associated defining entity. If the @@ -775,8 +777,12 @@ package Sem_Util is 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. Note that the implementation - -- takes the No_Implicit_Aiasing restriction into account. + -- 'Access or 'Unchecked_Access can apply. Note that this routine uses the + -- rules of the language, it does not take into account the restriction + -- No_Implicit_Aliasing, so it can return True if the restriction is active + -- and Obj violates the restriction. The caller is responsible for calling + -- Restrict.Check_No_Implicit_Aliasing if True is returned, but there is a + -- requirement for obeying the restriction in the call context. function Is_Ancestor_Package (E1 : Entity_Id; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index b36b930b8c4..440cf02a2e7 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -657,6 +657,7 @@ package body Sinfo is (N : Node_Id) return Node_Id is begin pragma Assert (False + or else NT (N).Nkind = N_Expression_Function or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Protected_Body or else NT (N).Nkind = N_Subprogram_Body @@ -1572,6 +1573,14 @@ package body Sinfo is return Flag13 (N); end Has_Wide_Wide_Character; + function Header_Size_Added + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + return Flag11 (N); + end Header_Size_Added; + function Hidden_By_Use_Clause (N : Node_Id) return Elist_Id is begin @@ -3729,6 +3738,7 @@ package body Sinfo is (N : Node_Id; Val : Node_Id) is begin pragma Assert (False + or else NT (N).Nkind = N_Expression_Function or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Protected_Body or else NT (N).Nkind = N_Subprogram_Body @@ -4635,6 +4645,14 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Has_Wide_Wide_Character; + procedure Set_Header_Size_Added + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Attribute_Reference); + Set_Flag11 (N, Val); + end Set_Header_Size_Added; + procedure Set_Hidden_By_Use_Clause (N : Node_Id; Val : Elist_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 35a73f9ad94..7e308ec328e 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -760,6 +760,9 @@ package Sinfo is -- renaming declaration when it is a Renaming_As_Body. The field is Empty -- if there is no corresponding spec, as in the case of a subprogram body -- that serves as its own spec. + -- + -- In Ada 2012, Corresponding_Spec is set on expression functions that + -- complete a subprogram declaration. -- Corresponding_Stub (Node3-Sem) -- This field is present in an N_Subunit node. It holds the node in @@ -1203,6 +1206,13 @@ package Sinfo is -- code outside the Wide_Character range) appears in the string. Used to -- implement pragma preference rules. + -- Header_Size_Added (Flag11-Sem) + -- Present in N_Attribute_Reference nodes, set only for attribute + -- Max_Size_In_Storage_Elements. The flag indicates that the size of the + -- hidden list header used by the runtime finalization support has been + -- added to the size of the prefix. The flag also prevents the infinite + -- expansion of the same attribute in the said context. + -- Hidden_By_Use_Clause (Elist4-Sem) -- An entity list present in use clauses that appear within -- instantiations. For the resolution of local entities, entities @@ -3324,6 +3334,7 @@ package Sinfo is -- Entity (Node4-Sem) used if the attribute yields a type -- Associated_Node (Node4-Sem) -- Do_Overflow_Check (Flag17-Sem) + -- Header_Size_Added (Flag11-Sem) -- Redundant_Use (Flag13-Sem) -- Must_Be_Byte_Aligned (Flag14) -- plus fields for expression @@ -4607,6 +4618,7 @@ package Sinfo is -- Sloc points to FUNCTION -- Specification (Node1) -- Expression (Node3) + -- Corresponding_Spec (Node5-Sem) ----------------------------------- -- 6.4 Procedure Call Statement -- @@ -7310,6 +7322,11 @@ package Sinfo is -- more sense to call it an Expression field, but then we would have to -- special case the treatment of the N_Reference node. + -- Note: evaluating a N_Reference node is guaranteed to yield a non-null + -- value at run time. Therefore, it is valid to set Is_Known_Non_Null on + -- a temporary initialized to a N_Reference node in order to eliminate + -- superfluous access checks. + -- Sprint syntax: prefix'reference -- N_Reference @@ -8547,6 +8564,9 @@ package Sinfo is function Has_Wide_Wide_Character (N : Node_Id) return Boolean; -- Flag13 + function Header_Size_Added + (N : Node_Id) return Boolean; -- Flag11 + function Hidden_By_Use_Clause (N : Node_Id) return Elist_Id; -- Elist4 @@ -9522,6 +9542,9 @@ package Sinfo is procedure Set_Has_Wide_Wide_Character (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Header_Size_Added + (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Hidden_By_Use_Clause (N : Node_Id; Val : Elist_Id); -- Elist4 @@ -11918,6 +11941,7 @@ package Sinfo is pragma Inline (Has_Task_Name_Pragma); pragma Inline (Has_Wide_Character); pragma Inline (Has_Wide_Wide_Character); + pragma Inline (Header_Size_Added); pragma Inline (Hidden_By_Use_Clause); pragma Inline (High_Bound); pragma Inline (Identifier); @@ -12239,6 +12263,7 @@ package Sinfo is pragma Inline (Set_Has_Task_Name_Pragma); pragma Inline (Set_Has_Wide_Character); pragma Inline (Set_Has_Wide_Wide_Character); + pragma Inline (Set_Header_Size_Added); pragma Inline (Set_Hidden_By_Use_Clause); pragma Inline (Set_High_Bound); pragma Inline (Set_Identifier); diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads index bdc268eaf0f..1d13f6e60be 100644 --- a/gcc/ada/sinput.ads +++ b/gcc/ada/sinput.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ -- described in RM 2.2 (13). Any of the characters FF, LF, CR or VT or any -- wide character that is a Line or Paragraph Separator acts as an end of -- logical line in this sense, and it is essentially irrelevant whether one --- or more appears in sequence (since if sequence of such characters is +-- or more appears in sequence (since if a sequence of such characters is -- regarded as separate ends of line, then the intervening logical lines -- are null in any case). @@ -451,6 +451,75 @@ package Sinput is Internal_Source'Unrestricted_Access; -- Pointer to internal source buffer + ----------------------------------------- + -- Handling of Source Line Terminators -- + ----------------------------------------- + + -- In this section we discuss in detail the issue of terminators used to + -- terminate source lines. The RM says that one or more format effectors + -- (other than horizontal tab) end a source line, and defines the set of + -- such format effectors, but does not talk about exactly how they are + -- represented in the source program (since in general the RM is not in + -- the business of specifying source program formats). + + -- The type Types.Line_Terminator is defined as a subtype of Character + -- that includes CR/LF/VT/FF. The most common line enders in practice + -- are CR (some MAC systems), LF (Unix systems), and CR/LF (DOS/Windows + -- systems). Any of these sequences is recognized as ending a physical + -- source line, and if multiple such terminators appear (e.g. LF/LF), + -- then we consider we have an extra blank line. + + -- VT and FF are recognized as terminating source lines, but they are + -- considered to end a logical line instead of a physical line, so that + -- the line numbering ignores such terminators. The use of VT and FF is + -- mandated by the standard, and correctly handled in a conforming manner + -- by GNAT, but their use is not recommended. + + -- In addition to the set of characters defined by the type in Types, in + -- wide character encoding, then the codes returning True for a call to + -- System.UTF_32.Is_UTF_32_Line_Terminator are also recognized as ending a + -- source line. This includes the standard codes defined above in addition + -- to NEL (NEXT LINE), LINE SEPARATOR and PARAGRAPH SEPARATOR. Again, as in + -- the case of VT and FF, the standard requires we recognize these as line + -- terminators, but we consider them to be logical line terminators. The + -- only physical line terminators recognized are the standard ones (CR, + -- LF, or CR/LF). + + -- However, we do not recognize the NEL (16#85#) character as having the + -- significance of an end of line character when operating in normal 8-bit + -- Latin-n input mode for the compiler. Instead the rule in this mode is + -- that all upper half control codes (16#80# .. 16#9F#) are illegal if they + -- occur in program text, and are ignored if they appear in comments. + + -- First, note that this behavior is fully conforming with the standard. + -- The standard has nothing whatever to say about source representation + -- and implementations are completely free to make there own rules. In + -- this case, in 8-bit mode, GNAT decides that the 16#0085# character is + -- not a representation of the NEL character, even though it looks like it. + -- If you have NEL's in your program, which you expect to be treated as + -- end of line characters, you must use a wide character encoding such as + -- UTF-8 for this code to be recognized. + + -- Second, an explanation of why we take this slightly surprising choice. + -- We have never encountered anyone actually using the NEL character to + -- end lines. One user raised the issue as a result of some experiments, + -- but no one has ever submitted a program encoded this way, in any of + -- the possible encodings. It seems that even when using wide character + -- codes extensively, the normal approach is to use standard line enders + -- (LF or CR/LF). So the failure to recognize NEL in this mode seems to + -- have no practical downside. + + -- Moreover, what we have seen in a significant number of programs from + -- multiple sources is the practice of writing all program text in lower + -- half (ASCII) form, but using UTF-8 encoded wide characters freely in + -- comments, where the comments are terminated by normal line endings + -- (LF or CR/LF). The comments do not contain NEL codes, but they can and + -- do contain other UTF-8 encoding sequences where one of the bytes is the + -- NEL code. Now such programs can of course be compiled in UTF-8 mode, + -- but in practice they also compile fine in standard 8-bit mode without + -- specifying a character encoding. Since this is common practice, it would + -- be a signficant upwards incompatibility to recognize NEL in 8-bit mode. + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 3ed2a668e00..d15892a5f02 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -524,6 +524,7 @@ package Snames is Name_Psect_Object : constant Name_Id := N + $; -- VMS Name_Pure : constant Name_Id := N + $; Name_Pure_05 : constant Name_Id := N + $; -- GNAT + Name_Pure_12 : constant Name_Id := N + $; -- GNAT Name_Pure_Function : constant Name_Id := N + $; -- GNAT Name_Relative_Deadline : constant Name_Id := N + $; -- Ada 05 Name_Remote_Call_Interface : constant Name_Id := N + $; @@ -1672,6 +1673,7 @@ package Snames is Pragma_Psect_Object, Pragma_Pure, Pragma_Pure_05, + Pragma_Pure_12, Pragma_Pure_Function, Pragma_Relative_Deadline, Pragma_Remote_Call_Interface, diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 4d383fd0608..a4456f56a24 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -80,54 +80,6 @@ extern struct tm *localtime_r(const time_t *, struct tm *); #endif /* - mode_read_text - open text file for reading - rt for DOS and Windows NT, r for Unix - - mode_write_text - truncate to zero length or create text file for writing - wt for DOS and Windows NT, w for Unix - - mode_append_text - append; open or create text file for writing at end-of-file - at for DOS and Windows NT, a for Unix - - mode_read_binary - open binary file for reading - rb for DOS and Windows NT, r for Unix - - mode_write_binary - truncate to zero length or create binary file for writing - wb for DOS and Windows NT, w for Unix - - mode_append_binary - append; open or create binary file for writing at end-of-file - ab for DOS and Windows NT, a for Unix - - mode_read_text_plus - open text file for update (reading and writing) - r+t for DOS and Windows NT, r+ for Unix - - mode_write_text_plus - truncate to zero length or create text file for update - w+t for DOS and Windows NT, w+ for Unix - - mode_append_text_plus - append; open or create text file for update, writing at end-of-file - a+t for DOS and Windows NT, a+ for Unix - - mode_read_binary_plus - open binary file for update (reading and writing) - r+b for DOS and Windows NT, r+ for Unix - - mode_write_binary_plus - truncate to zero length or create binary file for update - w+b for DOS and Windows NT, w+ for Unix - - mode_append_binary_plus - append; open or create binary file for update, writing at end-of-file - a+b for DOS and Windows NT, a+ for Unix - Notes: (1) Opening a file with read mode fails if the file does not exist or @@ -169,18 +121,7 @@ extern struct tm *localtime_r(const time_t *, struct tm *); */ #if defined(WINNT) -static const char *mode_read_text = "rt"; -static const char *mode_write_text = "wt"; -static const char *mode_append_text = "at"; -static const char *mode_read_binary = "rb"; -static const char *mode_write_binary = "wb"; -static const char *mode_append_binary = "ab"; -static const char *mode_read_text_plus = "r+t"; -static const char *mode_write_text_plus = "w+t"; -static const char *mode_append_text_plus = "a+t"; -static const char *mode_read_binary_plus = "r+b"; -static const char *mode_write_binary_plus = "w+b"; -static const char *mode_append_binary_plus = "a+b"; + const char __gnat_text_translation_required = 1; void @@ -261,18 +202,6 @@ __gnat_get_stack_bounds (void **base, void **limit) #else -static const char *mode_read_text = "r"; -static const char *mode_write_text = "w"; -static const char *mode_append_text = "a"; -static const char *mode_read_binary = "r"; -static const char *mode_write_binary = "w"; -static const char *mode_append_binary = "a"; -static const char *mode_read_text_plus = "r+"; -static const char *mode_write_text_plus = "w+"; -static const char *mode_append_text_plus = "a+"; -static const char *mode_read_binary_plus = "r+"; -static const char *mode_write_binary_plus = "w+"; -static const char *mode_append_binary_plus = "a+"; const char __gnat_text_translation_required = 0; /* These functions do nothing in non-DOS systems. */ diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c new file mode 100644 index 00000000000..464e60a28aa --- /dev/null +++ b/gcc/ada/terminals.c @@ -0,0 +1,1551 @@ +/**************************************************************************** + * * + * GNAT RUN-TIME COMPONENTS * + * * + * T E R M I N A L S * + * * + * C Implementation File * + * * + * Copyright (C) 2008-2011, AdaCore * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * <http://www.gnu.org/licenses/>. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* First all usupported platforms. Add stubs for exported routines. */ + +#if defined (VMS) || defined (__vxworks) || defined (__Lynx__) + +void * __gnat_new_tty (void) { return (void*)0; } +char * __gnat_tty_name (void* t) { return (char*)0; } +int __gnat_interrupt_pid (int pid) { return -1; } +int __gnat_interrupt_process (void* desc) { return -1; } +int __gnat_setup_communication (void** desc) { return -1; } +void __gnat_setup_parent_communication + (void* d, int* i, int* o, int*e, int*p) { return -1; } +int __gnat_setup_child_communication + (void* d, char **n, int u) { return -1; } +int __gnat_terminate_process (void *desc) { return -1; } +int __gnat_tty_fd (void* t) { return -1; } +int __gnat_tty_supported (void) { return 0; } +int __gnat_tty_waitpid (void *desc) { return 1; } +void __gnat_close_tty (void* t) {} +void __gnat_free_process (void** process) {} +void __gnat_reset_tty (void* t) {} +void __gnat_send_header (void* d, char h[5], int s, int *r) {} +void __gnat_setup_winsize (void *desc, int rows, int columns) {} + +/* For Windows platforms. */ + +#elif defined(_WIN32) + +#include <errno.h> +#include <stdio.h> +#include <stdlib.h> + +#include <windows.h> + +#define MAXPATHLEN 1024 + +#define NILP(x) ((x) == 0) +#define Qnil 0 +#define report_file_error(x, y) fprintf (stderr, "Error: %s\n", x); +#define INTEGERP(x) 1 +#define XINT(x) x + +struct TTY_Process { + int pid; /* Number of this process */ + PROCESS_INFORMATION procinfo; + HANDLE w_infd, w_outfd; + HANDLE w_forkin, w_forkout; + BOOL usePipe; +}; + +/* Control whether create_child cause the process to inherit GPS' + error mode setting. The default is 1, to minimize the possibility of + subprocesses blocking when accessing unmounted drives. */ +static int Vw32_start_process_inherit_error_mode = 1; + +/* Control whether spawnve quotes arguments as necessary to ensure + correct parsing by child process. Because not all uses of spawnve + are careful about constructing argv arrays, we make this behaviour + conditional (off by default, since a similar operation is already done + in g-expect.adb by calling Normalize_Argument). */ +static int Vw32_quote_process_args = 0; + +static DWORD AbsoluteSeek(HANDLE, DWORD); +static VOID ReadBytes(HANDLE, LPVOID, DWORD); + +#define XFER_BUFFER_SIZE 2048 + +/* This tell if the executable we're about to launch uses a GUI interface. */ +/* if we can't determine it, we will return true */ +static int +is_gui_app (char *exe) +{ + HANDLE hImage; + + DWORD bytes; + DWORD iSection; + DWORD SectionOffset; + DWORD CoffHeaderOffset; + DWORD MoreDosHeader[16]; + CHAR *file; + size_t nlen; + + ULONG ntSignature; + + IMAGE_DOS_HEADER image_dos_header; + IMAGE_FILE_HEADER image_file_header; + IMAGE_OPTIONAL_HEADER image_optional_header; + IMAGE_SECTION_HEADER image_section_header; + + /* + * Open the reference file. + */ + nlen = strlen (exe); + file = exe; + if (nlen > 2) { + if (exe[0] == '"') { + /* remove quotes */ + nlen -= 2; + file = malloc ((nlen + 1) * sizeof (char)); + memcpy (file, &exe[1], nlen); + file [nlen] = '\0'; + } + } + hImage = CreateFile(file, + GENERIC_READ, + FILE_SHARE_READ, + NULL, + OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, + NULL); + + if (file != exe) { + free (file); + } + + if (INVALID_HANDLE_VALUE == hImage) + { + report_file_error ("Could not open exe: ", Qnil); + report_file_error (exe, Qnil); + report_file_error ("\n", Qnil); + CloseHandle (hImage); + return -1; + } + + /* + * Read the MS-DOS image header. + */ + ReadBytes(hImage, &image_dos_header, sizeof(IMAGE_DOS_HEADER)); + + if (IMAGE_DOS_SIGNATURE != image_dos_header.e_magic) + { + report_file_error("Sorry, I do not understand this file.\n", Qnil); + CloseHandle (hImage); + return -1; + } + + /* + * Read more MS-DOS header. */ + ReadBytes(hImage, MoreDosHeader, sizeof(MoreDosHeader)); + /* + * Get actual COFF header. + */ + CoffHeaderOffset = AbsoluteSeek(hImage, image_dos_header.e_lfanew) + + sizeof(ULONG); + if (CoffHeaderOffset < 0) { + CloseHandle (hImage); + return -1; + } + + ReadBytes (hImage, &ntSignature, sizeof(ULONG)); + + if (IMAGE_NT_SIGNATURE != ntSignature) + { + report_file_error ("Missing NT signature. Unknown file type.\n", Qnil); + CloseHandle (hImage); + return -1; + } + + SectionOffset = CoffHeaderOffset + IMAGE_SIZEOF_FILE_HEADER + + IMAGE_SIZEOF_NT_OPTIONAL_HEADER; + + ReadBytes(hImage, &image_file_header, IMAGE_SIZEOF_FILE_HEADER); + + /* + * Read optional header. + */ + ReadBytes(hImage, + &image_optional_header, + IMAGE_SIZEOF_NT_OPTIONAL_HEADER); + + CloseHandle (hImage); + + switch (image_optional_header.Subsystem) + { + case IMAGE_SUBSYSTEM_UNKNOWN: + return 1; + break; + + case IMAGE_SUBSYSTEM_NATIVE: + return 1; + break; + + case IMAGE_SUBSYSTEM_WINDOWS_GUI: + return 1; + break; + + case IMAGE_SUBSYSTEM_WINDOWS_CUI: + return 0; + break; + + case IMAGE_SUBSYSTEM_OS2_CUI: + return 0; + break; + + case IMAGE_SUBSYSTEM_POSIX_CUI: + return 0; + break; + + default: + /* Unknown, return GUI app to be preservative: if yes, it will be + correctly launched, if no, it will be launched, and a console will + be also displayed, which is not a big deal */ + return 1; + break; + } + +} + +static DWORD +AbsoluteSeek (HANDLE hFile, DWORD offset) +{ + DWORD newOffset; + + newOffset = SetFilePointer (hFile, offset, NULL, FILE_BEGIN); + + if (newOffset == 0xFFFFFFFF) + return -1; + else + return newOffset; +} + +static VOID +ReadBytes (HANDLE hFile, LPVOID buffer, DWORD size) +{ + DWORD bytes; + + if (!ReadFile(hFile, buffer, size, &bytes, NULL)) + { + size = 0; + return; + } + else if (size != bytes) + { + return; + } +} + +static int +nt_spawnve (char *exe, char **argv, char *env, struct TTY_Process *process) +{ + STARTUPINFO start; + SECURITY_ATTRIBUTES sec_attrs; + SECURITY_DESCRIPTOR sec_desc; + DWORD flags; + char dir[ MAXPATHLEN ]; + int pid; + int is_gui, use_cmd; + char *cmdline, *parg, **targ; + int do_quoting = 0; + char escape_char; + int arglen; + + /* we have to do some conjuring here to put argv and envp into the + form CreateProcess wants... argv needs to be a space separated/null + terminated list of parameters, and envp is a null + separated/double-null terminated list of parameters. + + Additionally, zero-length args and args containing whitespace or + quote chars need to be wrapped in double quotes - for this to work, + embedded quotes need to be escaped as well. The aim is to ensure + the child process reconstructs the argv array we start with + exactly, so we treat quotes at the beginning and end of arguments + as embedded quotes. + + Note that using backslash to escape embedded quotes requires + additional special handling if an embedded quote is already + preceeded by backslash, or if an arg requiring quoting ends with + backslash. In such cases, the run of escape characters needs to be + doubled. For consistency, we apply this special handling as long + as the escape character is not quote. + + Since we have no idea how large argv and envp are likely to be we + figure out list lengths on the fly and allocate them. */ + + if (!NILP (Vw32_quote_process_args)) + { + do_quoting = 1; + /* Override escape char by binding w32-quote-process-args to + desired character, or use t for auto-selection. */ + if (INTEGERP (Vw32_quote_process_args)) + escape_char = XINT (Vw32_quote_process_args); + else + escape_char = '\\'; + } + + /* do argv... */ + arglen = 0; + targ = argv; + while (*targ) + { + char *p = *targ; + int need_quotes = 0; + int escape_char_run = 0; + + if (*p == 0) + need_quotes = 1; + for ( ; *p; p++) + { + if (*p == '"') + { + /* allow for embedded quotes to be escaped */ + arglen++; + need_quotes = 1; + /* handle the case where the embedded quote is already escaped */ + if (escape_char_run > 0) + { + /* To preserve the arg exactly, we need to double the + preceding escape characters (plus adding one to + escape the quote character itself). */ + arglen += escape_char_run; + } + } + else if (*p == ' ' || *p == '\t') + { + need_quotes = 1; + } + + if (*p == escape_char && escape_char != '"') + escape_char_run++; + else + escape_char_run = 0; + } + if (need_quotes) + { + arglen += 2; + /* handle the case where the arg ends with an escape char - we + must not let the enclosing quote be escaped. */ + if (escape_char_run > 0) + arglen += escape_char_run; + } + arglen += strlen (*targ) + 1; + targ++; + } + + is_gui = is_gui_app (argv[0]); + use_cmd = FALSE; + + if (is_gui == -1) { + /* could not determine application type. Try launching with "cmd /c" */ + is_gui = FALSE; + arglen += 7; + use_cmd = TRUE; + } + + cmdline = (char*)malloc (arglen + 1); + targ = argv; + parg = cmdline; + + if (use_cmd == TRUE) { + strcpy (parg, "cmd /c "); + parg += 7; + } + + while (*targ) + { + char * p = *targ; + int need_quotes = 0; + + if (*p == 0) + need_quotes = 1; + + if (do_quoting) + { + for ( ; *p; p++) + if (*p == ' ' || *p == '\t' || *p == '"') + need_quotes = 1; + } + if (need_quotes) + { + int escape_char_run = 0; + char * first; + char * last; + + p = *targ; + first = p; + last = p + strlen (p) - 1; + *parg++ = '"'; + for ( ; *p; p++) + { + if (*p == '"') + { + /* double preceding escape chars if any */ + while (escape_char_run > 0) + { + *parg++ = escape_char; + escape_char_run--; + } + /* escape all quote chars, even at beginning or end */ + *parg++ = escape_char; + } + *parg++ = *p; + + if (*p == escape_char && escape_char != '"') + escape_char_run++; + else + escape_char_run = 0; + } + /* double escape chars before enclosing quote */ + while (escape_char_run > 0) + { + *parg++ = escape_char; + escape_char_run--; + } + *parg++ = '"'; + } + else + { + strcpy (parg, *targ); + parg += strlen (*targ); + } + *parg++ = ' '; + targ++; + } + *--parg = '\0'; + + memset (&start, 0, sizeof (start)); + start.cb = sizeof (start); + + if (process->usePipe == TRUE) { + start.dwFlags = STARTF_USESTDHANDLES; + start.hStdInput = process->w_forkin; + start.hStdOutput = process->w_forkout; + /* child's stderr is always redirected to outfd */ + start.hStdError = process->w_forkout; + } else { + start.dwFlags = STARTF_USESTDHANDLES; + /* We only need to redirect stderr/stdout here. Stdin will be forced to + the spawned process console by explaunch */ + start.hStdInput = NULL; + start.hStdOutput = process->w_forkout; + start.hStdError = process->w_forkout; + } + + /* Explicitly specify no security */ + if (!InitializeSecurityDescriptor (&sec_desc, SECURITY_DESCRIPTOR_REVISION)) + goto EH_Fail; + if (!SetSecurityDescriptorDacl (&sec_desc, TRUE, NULL, FALSE)) + goto EH_Fail; + sec_attrs.nLength = sizeof (sec_attrs); + sec_attrs.lpSecurityDescriptor = &sec_desc; + sec_attrs.bInheritHandle = FALSE; + + /* creating a new console allow easier close. Do not use + CREATE_NEW_PROCESS_GROUP as this results in disabling Ctrl+C */ + flags = CREATE_NEW_CONSOLE; + if (NILP (Vw32_start_process_inherit_error_mode)) + flags |= CREATE_DEFAULT_ERROR_MODE; + + /* if app is not a gui application, hide the console */ + if (is_gui == FALSE) { + start.dwFlags |= STARTF_USESHOWWINDOW; + start.wShowWindow = SW_HIDE; + } + + /* Set initial directory to null character to use current directory */ + if (!CreateProcess (NULL, cmdline, &sec_attrs, NULL, TRUE, + flags, env, NULL, &start, &process->procinfo)) + goto EH_Fail; + + pid = (int) process->procinfo.hProcess; + process->pid=pid; + + return pid; + + EH_Fail: + return -1; +} + +/************************* + ** __gnat_send_header () + *************************/ + +#define EXP_SLAVE_CREATE 'c' +#define EXP_SLAVE_KEY 'k' +#define EXP_SLAVE_MOUSE 'm' +#define EXP_SLAVE_WRITE 'w' +#define EXP_SLAVE_KILL 'x' + +#define EXP_KILL_TERMINATE 0x1 +#define EXP_KILL_CTRL_C 0x2 +#define EXP_KILL_CTRL_BREAK 0x4 + +void +__gnat_send_header (struct TTY_Process* p, char header[5], int size, int *ret) +{ + if (p->usePipe == FALSE) { + header[0] = EXP_SLAVE_WRITE; + header[1] = size & 0xff; + header[2] = (size & 0xff00) >> 8; + header[3] = (size & 0xff0000) >> 16; + header[4] = (size & 0xff000000) >> 24; + *ret = 1; + } else { + *ret = 0; + } +} + +/********************************** + ** __gnat_setup_communication () + **********************************/ + +int +__gnat_setup_communication (struct TTY_Process** process_out) /* output param */ +{ + struct TTY_Process* process; + + process = (struct TTY_Process*)malloc (sizeof (struct TTY_Process)); + ZeroMemory (process, sizeof (struct TTY_Process)); + *process_out = process; + + return 0; +} + +#define EXP_PIPE_BASENAME "\\\\.\\pipe\\ExpectPipe" + +int +__gnat_setup_child_communication + (struct TTY_Process* process, + char** argv, + int Use_Pipes) +{ + int cpid; + HANDLE parent; + SECURITY_ATTRIBUTES sec_attrs; + char slavePath [MAX_PATH]; + char **nargv; + int argc; + int i; + char pipeNameIn[100]; + HANDLE hSlaveInDrv = NULL; /* Handle to communicate with slave driver */ + + parent = GetCurrentProcess (); + + /* Set inheritance for the pipe handles */ + sec_attrs.nLength = sizeof (SECURITY_ATTRIBUTES); + sec_attrs.bInheritHandle = TRUE; + sec_attrs.lpSecurityDescriptor = NULL; + + if (Use_Pipes) { + /* Create in and out pipes */ + if (!CreatePipe (&process->w_forkin, &process->w_infd, &sec_attrs, 0)) + report_file_error ("Creation of child's IN handle", Qnil); + if (!CreatePipe (&process->w_outfd, &process->w_forkout, &sec_attrs, 0)) + report_file_error ("Creation of child's OUT handle", Qnil); + + /* Do not inherit the parent's side of the pipes */ + SetHandleInformation (&process->w_infd, HANDLE_FLAG_INHERIT, 0); + SetHandleInformation (&process->w_outfd, HANDLE_FLAG_INHERIT, 0); + + /* use native argv */ + nargv = argv; + process->usePipe = TRUE; + + } else { + static int pipeNameId = 0; + + process->w_infd = NULL; + + /* We create a named pipe for Input, as we handle input by sending special + commands to the explaunch process, that uses it to feed the actual input + of the process */ + sprintf(pipeNameIn, "%sIn%08x_%08x", EXP_PIPE_BASENAME, + GetCurrentProcessId(), pipeNameId); + pipeNameId++; + + hSlaveInDrv = CreateNamedPipe(pipeNameIn, + PIPE_ACCESS_OUTBOUND, + PIPE_TYPE_BYTE | PIPE_WAIT, 1, 8192, 8192, + 20000, NULL); + if (hSlaveInDrv == NULL) goto end; + + if (!CreatePipe (&process->w_outfd, &process->w_forkout, &sec_attrs, 0)) + report_file_error ("Creation of child's OUT handle", Qnil); + + if (SearchPath (NULL, "explaunch.exe", NULL, + MAX_PATH, slavePath, NULL) == 0) goto end; + + for (argc=0; argv[argc] != NULL; argc++) ; + nargv = (char **) malloc (sizeof (char*) * (argc + 3)); + nargv[0] = slavePath; + nargv[1] = pipeNameIn; + + for (i = 0; i <= argc; i++) nargv[i + 2] = argv[i]; + process->usePipe = FALSE; + } + + /* Spawn the child. */ + cpid = nt_spawnve (nargv[0], nargv, NULL, process); + + /* close the duplicated handles passed to the child */ + CloseHandle (process->w_forkout); + + if (process->usePipe == TRUE) { + CloseHandle (process->w_forkin); + + } else { + UCHAR buf[8]; /* enough space for child status info */ + DWORD count; + BOOL bRet; + DWORD dwRet; + + /* + * Wait for connection with the slave driver + */ + bRet = ConnectNamedPipe(hSlaveInDrv, NULL); + if (bRet == FALSE) { + dwRet = GetLastError(); + if (dwRet == ERROR_PIPE_CONNECTED) { + ; + } else { + goto end; + } + } + + process->w_infd = hSlaveInDrv; + + /* + * wait for slave driver to initialize before allowing user to send to it + */ + bRet = ReadFile(process->w_outfd, buf, 8, &count, NULL); + if (bRet == FALSE) { + cpid = -1; + } + + dwRet = buf[0] | (buf[1] << 8) | (buf[2] << 16) | (buf[3] << 24); + if (dwRet != 0) { + cpid = -1; + } + + cpid = buf[4] | (buf[5] << 8) | (buf[6] << 16) | (buf[7] << 24); + process->pid = cpid; + } + + if (cpid == -1) + /* An error occurred while trying to spawn the process. */ + report_file_error ("Spawning child process", Qnil); + + return cpid; + end: + if (hSlaveInDrv != NULL) + CloseHandle (hSlaveInDrv); + return -1; +} + +void +__gnat_setup_parent_communication + (struct TTY_Process* process, + int* in, + int* out, + int* err, + int* pid) +{ + *in = _open_osfhandle ((long) process->w_infd, 0); + *out = _open_osfhandle ((long) process->w_outfd, 0); + /* child's stderr is always redirected to outfd */ + *err = *out; + *pid = process->pid; +} + +typedef struct _child_process +{ + HWND hwnd; + PROCESS_INFORMATION *procinfo; +} child_process; + +/* The major and minor versions of NT. */ +static int w32_major_version; +static int w32_minor_version; + +/* Distinguish between Windows NT and Windows 95. */ +static enum {OS_UNKNOWN, OS_WIN95, OS_NT} os_subtype = OS_UNKNOWN; + +/* Cache information describing the NT system for later use. */ +static void +cache_system_info (void) +{ + union + { + struct info + { + char major; + char minor; + short platform; + } info; + DWORD data; + } version; + + /* Cache the version of the operating system. */ + version.data = GetVersion (); + w32_major_version = version.info.major; + w32_minor_version = version.info.minor; + + if (version.info.platform & 0x8000) + os_subtype = OS_WIN95; + else + os_subtype = OS_NT; +} + +static BOOL CALLBACK +find_child_console (HWND hwnd, child_process * cp) +{ + DWORD thread_id; + DWORD process_id; + + thread_id = GetWindowThreadProcessId (hwnd, &process_id); + if (process_id == cp->procinfo->dwProcessId) + { + char window_class[32]; + + GetClassName (hwnd, window_class, sizeof (window_class)); + if (strcmp (window_class, + (os_subtype == OS_WIN95) + ? "tty" + : "ConsoleWindowClass") == 0) + { + cp->hwnd = hwnd; + return FALSE; + } + } + /* keep looking */ + return TRUE; +} + +int +__gnat_interrupt_process (struct TTY_Process* p) +{ + char buf[2]; + DWORD written; + BOOL bret; + + if (p->usePipe == TRUE) { + bret = FALSE; + } else { + buf[0] = EXP_SLAVE_KILL; + buf[1] = EXP_KILL_CTRL_C; + bret = WriteFile (p->w_infd, buf, 2, &written, NULL); + } + + if (bret == FALSE) { + return __gnat_interrupt_pid (p->procinfo.dwProcessId); + } + return 0; +} + +int +__gnat_interrupt_pid (int pid) +{ + volatile child_process cp; + int rc = 0; + + cp.procinfo = (LPPROCESS_INFORMATION) malloc (sizeof (PROCESS_INFORMATION)); + cp.procinfo->dwProcessId = pid; + + if (os_subtype == OS_UNKNOWN) + cache_system_info (); + + /* Try to locate console window for process. */ + EnumWindows ((WNDENUMPROC) find_child_console, (LPARAM) &cp); + + if (cp.hwnd) + { + BYTE control_scan_code = (BYTE) MapVirtualKey (VK_CONTROL, 0); + /* Retrieve Ctrl-C scancode */ + BYTE vk_break_code = 'C'; + BYTE break_scan_code = (BYTE) MapVirtualKey (vk_break_code, 0); + HWND foreground_window; + + foreground_window = GetForegroundWindow (); + if (foreground_window) + { + /* NT 5.0, and apparently also Windows 98, will not allow + a Window to be set to foreground directly without the + user's involvement. The workaround is to attach + ourselves to the thread that owns the foreground + window, since that is the only thread that can set the + foreground window. */ + DWORD foreground_thread, child_thread; + + foreground_thread = + GetWindowThreadProcessId (foreground_window, NULL); + if (foreground_thread == GetCurrentThreadId () + || !AttachThreadInput (GetCurrentThreadId (), + foreground_thread, TRUE)) + foreground_thread = 0; + + child_thread = GetWindowThreadProcessId (cp.hwnd, NULL); + if (child_thread == GetCurrentThreadId () + || !AttachThreadInput (GetCurrentThreadId (), + child_thread, TRUE)) + child_thread = 0; + + /* Set the foreground window to the child. */ + if (SetForegroundWindow (cp.hwnd)) + { + /* Generate keystrokes as if user had typed Ctrl-Break or + Ctrl-C. */ + keybd_event (VK_CONTROL, control_scan_code, 0, 0); + keybd_event (vk_break_code, break_scan_code, + (vk_break_code == 'C' ? 0 : KEYEVENTF_EXTENDEDKEY), 0); + keybd_event (vk_break_code, break_scan_code, + (vk_break_code == 'C' ? 0 : KEYEVENTF_EXTENDEDKEY) + | KEYEVENTF_KEYUP, 0); + keybd_event (VK_CONTROL, control_scan_code, KEYEVENTF_KEYUP, 0); + + /* Sleep for a bit to give time for the main frame to respond + to focus change events. */ + Sleep (100); + + SetForegroundWindow (foreground_window); + } + /* Detach from the foreground and child threads now that + the foreground switching is over. */ + if (foreground_thread) + AttachThreadInput (GetCurrentThreadId (), foreground_thread, FALSE); + if (child_thread) + AttachThreadInput (GetCurrentThreadId (), child_thread, FALSE); + } + } + /* Ctrl-Break is NT equivalent of SIGINT. */ + else if (!GenerateConsoleCtrlEvent + (CTRL_BREAK_EVENT, cp.procinfo->dwProcessId)) + { + errno = EINVAL; + rc = -1; + } + + free (cp.procinfo); + return rc; +} + +/* kill a process, as this implementation use CreateProcess on Win32 we need + to use Win32 TerminateProcess API */ +int +__gnat_terminate_process (struct TTY_Process* p) +{ + char buf[2]; + DWORD written; + BOOL bret; + + if (p->usePipe == TRUE) { + bret = FALSE; + } else { + buf[0] = EXP_SLAVE_KILL; + buf[1] = EXP_KILL_TERMINATE; + bret = WriteFile (p->w_infd, buf, 2, &written, NULL); + } + + if (bret == FALSE) { + if (!TerminateProcess (p->procinfo.hProcess, 1)) + return -1; + else + return 0; + } else + return 0; +} + +/* wait for process pid to terminate and return the process status. This + implementation is different from the adaint.c one for Windows as it uses + the Win32 API instead of the C one. */ + +int +__gnat_tty_waitpid (struct TTY_Process* p) +{ + DWORD exitcode; + DWORD res; + HANDLE proc_hand = p->procinfo.hProcess; + + res = WaitForSingleObject (proc_hand, 0); + GetExitCodeProcess (proc_hand, &exitcode); + + CloseHandle (p->procinfo.hThread); + CloseHandle (p->procinfo.hProcess); + + /* No need to close the handles: they were closed on the ada side */ + + return (int) exitcode; +} + +/******************************** + ** __gnat_free_process () + ********************************/ + +void +__gnat_free_process (struct TTY_Process** process) +{ + free (*process); + *process = NULL; +} + +/* TTY handling */ + +typedef struct { + int tty_fd; /* descriptor for the tty */ + char tty_name[24]; /* Name of TTY device */ +} TTY_Handle; + +int +__gnat_tty_supported (void) +{ + return 0; +} + +/* Return the tty name associated with p */ + +char * +__gnat_tty_name (TTY_Handle* t) +{ + return t->tty_name; +} + +int +__gnat_tty_fd (TTY_Handle* t) +{ + return t->tty_fd; +} + +TTY_Handle* +__gnat_new_tty (void) +{ + return (TTY_Handle*)0; +} + +void +__gnat_reset_tty (TTY_Handle* t) +{ + return; +} + +void +__gnat_close_tty (TTY_Handle* t) +{ + free (t); +} + +void +__gnat_setup_winsize (void *desc, int rows, int columns) +{ +} + +#else /* defined(_WIN32, implementatin for all UNIXes */ + +/* First defined some macro to identify easily some systems */ +#if defined (__FreeBSD__) \ + || defined (__OpenBSD__) \ + || defined (__NetBSD__) \ + || defined (__DragonFly__) +# define FREEBSD +#endif +#if defined (__alpha__) && defined (__osf__) +# define OSF1 +#endif +#if defined (__mips) && defined (__sgi) +# define IRIX +#endif + +/* Include every system header we need */ +#define _GNU_SOURCE +#include <errno.h> +#include <stdio.h> +#include <stdlib.h> + +/* On some system termio is either absent or including it will disable termios + (HP-UX) */ +#if ! defined (__hpux__) && ! defined (FREEBSD) && ! defined (__APPLE__) +# include <termio.h> +#endif + +#include <sys/ioctl.h> +#include <termios.h> +#include <fcntl.h> +#include <string.h> +#include <sys/stat.h> +#include <sys/types.h> +#include <sys/wait.h> +#include <unistd.h> +#if defined (sun) +# include <sys/stropts.h> +#endif +#if defined (FREEBSD) || defined (sun) +# include <sys/signal.h> +#endif +#if defined (__hpux__) +# include <sys/termio.h> +# include <sys/stropts.h> +#endif + +#define CDISABLE _POSIX_VDISABLE + +/* On HP-UX and Sun system, there is a bzero function but with a different + signature. Use memset instead */ +#if defined (__hpux__) || defined (sun) || defined (_AIX) +# define bzero(s,n) memset (s,0,n) +#endif + +/* POSIX does not specify how to open the master side of a terminal.Several + methods are available (system specific): + 1- using a cloning device (USE_CLONE_DEVICE) + 2- getpt (USE_GETPT) + 3- openpty (USE_OPENPTY) + 4- _getpty (USE_GETPTY) + + When using the cloning device method, the macro USE_CLONE_DEVICE should + contains a full path to the adequate device. + + When a new system is about to be supported, one of the previous macro should + be set otherwise allocate_pty_desc will return an error +*/ + +/* Configurable part */ +#if defined (__APPLE__) || defined (FREEBSD) +#define USE_OPENPTY +#elif defined (IRIX) +#define USE_GETPTY +#elif defined (linux) +#define USE_GETPT +#elif defined (sun) +#define USE_CLONE_DEVICE "/dev/ptmx" +#elif defined (_AIX) +#define USE_CLONE_DEVICE "/dev/ptc" +#elif defined (OSF1) +/* On Tru64, the systems offers various interfaces to open a terminal: + - /dev/ptmx: this the system V driver (stream based), + - /dev/ptmx_bsd: the non stream based clone device, + - the openpty function which use BSD interface. + + Using directly /dev/ptmx_bsd on Tru64 5.1B seems to consume all the + available slave ptys (why ?). When using openpty it seems that the function + handles the creation of entries in /dev/pts when necessary and so avoid this + starvation issue. The pty man entry suggests also to use openpty. +*/ +#define USE_OPENPTY +#elif defined (__hpux__) +/* On HP-UX we use the streamed version. Using the non streamed version is not + recommanded (through "/dev/ptym/clone"). Indeed it seems that there are + issues to detect process terminations. */ +#define USE_CLONE_DEVICE "/dev/ptmx" +#endif + +/* structure that holds information about the terminal used and the process + connected on the slave side */ +typedef struct pty_desc_struct { + int master_fd; /* fd of the master side if the terminal */ + int slave_fd; /* fd of the slave side */ + char slave_name[32]; /* filename of the slave side */ + int child_pid; /* PID of the child process connected to the slave side + of the terminal */ +} pty_desc; + +/* allocate_pty_desc - allocate a pseudo terminal + * + * PARAMETERS + * out desc returned pointer to a pty_desc structure containing information + * about the opened pseudo terminal + * RETURN VALUE + * -1 if failed + * 0 if ok + * COMMENTS + * If the function is successful we should have at least the master side fd + * and the slave side filename. On some system, the slave side will also be + * opened. If this is not the case the slave side will be open once we are in + * the child process (note that opening the slave side at this stage will + * failed...). + */ + +extern char* ptsname (int); + +static int +allocate_pty_desc (pty_desc **desc) { + + pty_desc *result; + int status = 0; + int slave_fd = -1; + int master_fd = -1; + char *slave_name = NULL; + +#ifdef USE_GETPT + master_fd = getpt (); +#elif defined (USE_OPENPTY) + status = openpty (&master_fd, &slave_fd, NULL, NULL, NULL); +#elif defined (USE_GETPTY) + slave_name = _getpty (&master_fd, O_RDWR | O_NDELAY, 0600, 0); + if (slave_name == NULL) status = -1; +#elif defined (USE_CLONE_DEVICE) + master_fd = open (USE_CLONE_DEVICE, O_RDWR | O_NONBLOCK, 0); +#else + printf ("[error]: terminal support is not configured\n"); + return -1; +#endif + + /* at this stage we should have the master side fd and status should be 0 */ + if (status != 0 || master_fd < 0) + { + /* If this is not the case close all opened files and return -1 */ + printf ("[error]: cannot allocate master side of the pty\n"); + if (master_fd >= 0) close (master_fd); + if (slave_fd >= 0) close (slave_fd); + *desc = NULL; + return -1; + } + + /* retrieve the file name of the slave side if necessary */ + if (slave_name == NULL) slave_name = (char *) ptsname (master_fd); + + /* Now we should have slave file name */ + if (slave_name == NULL) + { + /* If not the case close any opened file and return - 1 */ + printf ("[error]: cannot allocate slave side of the pty\n"); + if (master_fd >= 0) close (master_fd); + if (slave_fd >= 0) close (slave_fd); + *desc = NULL; + return -1; + } + + /* grant access to the slave side */ + grantpt (master_fd); + /* unlock the terminal */ + unlockpt (master_fd); + + /* set desc and return 0 */ + result = malloc (sizeof (pty_desc)); + result->master_fd = master_fd; + result->slave_fd = slave_fd; + /* the string returned by ptsname or _getpty is a static allocated string. So + we should make a copy */ + strncpy (result->slave_name, slave_name, sizeof (result->slave_name)); + result->slave_name[sizeof (result->slave_name) - 1] = '\0'; + result->child_pid = -1; + *desc=result; + return 0; +} + +/* some utility macro that make the code of child_setup_tty easier to read */ +#define __enable(a, b) ((a) |= (b)) +#define __disable(a, b) ((a) &= ~(b)) + +/* some properties do not exist on all systems. Set their value to 0 in that + case */ +#ifndef IUCLC +#define IUCLC 0 +#endif +#ifndef OLCUC +#define OLCUC 0 +#endif +#ifndef NLDLY +#define NLDLY 0 +#define CRDLY 0 +#define TABDLY 0 +#define BSDLY 0 +#define VTDLY 0 +#define FFDLY 0 +#endif + +/* child_setup_tty - set terminal properties + * + * PARAMETERS + * file descriptor of the slave side of the terminal + * + * RETURN VALUE + * 0 if success, any other value if failed. + * + * COMMENTS + * None + */ +static int +child_setup_tty (int fd) +{ + struct termios s; + int status; + + /* ensure that s is filled with 0 */ + bzero (&s, sizeof (&s)); + + /* Get the current terminal settings */ + status = tcgetattr (fd, &s); + if (status != 0) return -1; + + /* Adjust input modes */ + __disable (s.c_iflag, IUCLC); /* don't transform to lower case */ + __disable (s.c_iflag, ISTRIP); /* don't delete 8th bit */ + + /* Adjust output modes */ + __enable (s.c_oflag, OPOST); /* enable postprocessing */ + __disable (s.c_oflag, ONLCR); /* don't map LF to CR-LF */ + __disable (s.c_oflag, NLDLY|CRDLY|TABDLY|BSDLY|VTDLY|FFDLY); + /* disable delays */ + __disable (s.c_oflag, OLCUC); /* don't transform to upper case */ + + /* Adjust control modes */ + s.c_cflag = (s.c_cflag & ~CSIZE) | CS8; /* Don't strip 8th bit */ + + /* Adjust local modes */ + __disable (s.c_lflag, ECHO); /* disable echo */ + __enable (s.c_lflag, ISIG); /* enable signals */ + __enable (s.c_lflag, ICANON); /* erase/kill/eof processing */ + + /* Adjust control characters */ + /* IMPORTANT: we need to ensure that Ctrl-C will trigger an interrupt signal + otherwise send_signal_via_characters will fail */ + s.c_cc[VEOF] = 04; /* insure that EOF is Control-D */ + s.c_cc[VERASE] = CDISABLE; /* disable erase processing */ + s.c_cc[VKILL] = CDISABLE; /* disable kill processing */ + s.c_cc[VQUIT] = 28; /* Control-\ */ + s.c_cc[VINTR] = 03; /* Control-C */ + s.c_cc[VEOL] = CDISABLE; + s.c_cc[VSUSP] = 26; /* Control-Z */ + + /* push our changes */ + status = tcsetattr (fd, TCSADRAIN, &s); + return status; +} + +/* __gnat_setup_communication - interface to the external world. Should be + * called before forking. On Unixes this function only call allocate_pty_desc. + * The Windows implementation (in different part of this file) is very + * different. + * + * PARAMETERS + * out desc returned pointer to a pty_desc structure + * RETURN VALUE + * 0 if success, -1 otherwise + */ +int __gnat_setup_communication (pty_desc** desc) { + return allocate_pty_desc (desc); +} + +/* __gnat_setup_parent_communication - interface to the external world. Should + * be called after forking in the parent process + * + * PARAMETERS + * out in_fd + out out_fd + out err_fd fds corresponding to the parent side of the + terminal + in pid_out child process pid + * RETRUN VALUE + * 0 + */ +void +__gnat_setup_parent_communication + (pty_desc *desc, + int* in_fd, /* input */ + int* out_fd, /* output */ + int* err_fd, /* error */ + int* pid_out) +{ + + *in_fd = desc->master_fd; + *out_fd= desc->master_fd; + *err_fd= desc->master_fd; + desc->child_pid = *pid_out; +} + +/* __gnat_setup_winsize - Sets up the size of the terminal + * This lets the process know the size of the terminal + */ + +void __gnat_setup_winsize (pty_desc *desc, int rows, int columns) { +#ifdef TIOCGWINSZ + struct winsize s; + s.ws_row = (unsigned short)rows; + s.ws_col = (unsigned short)columns; + s.ws_xpixel = 0; + s.ws_ypixel = 0; + ioctl (desc->master_fd, TIOCSWINSZ, &s); +#ifdef SIGWINCH + if (desc->child_pid > 0) { + /* Let the process know about the change in size */ + kill (desc->child_pid, SIGWINCH); + } +#endif +#endif +} + +/* __gnat_setup_child_communication - interface to external world. Should be + * called after forking in the child process. On Unixes, this function + * first adjust the line setting, set standard output, input and error and + * then spawn the program. + * + * PARAMETERS + * desc a pty_desc structure containing the pty parameters + * new_argv argv of the program to be spawned + * RETURN VALUE + * this function should not return + */ +int +__gnat_setup_child_communication + (pty_desc *desc, + char **new_argv, + int Use_Pipes) +{ + int status; + int pid = getpid (); + + setsid (); + + /* open the slave side of the terminal if necessary */ + if (desc->slave_fd == -1) +#if defined (_AIX) + /* On AIX, if the slave process is not opened with O_NDELAY or O_NONBLOCK + then we might have some processes hanging on I/O system calls. Not sure + we can do that for all platforms so do it only on AIX for the moment. + On AIX O_NONBLOCK and O_NDELAY have slightly different meanings. When + reading on the slave fd, in case there is no data available, if O_NDELAY + is set then 0 is returned. If O_NON_BLOCK is -1 is returned. It seems + that interactive programs such as GDB prefer the O_NDELAY behavior. + We chose O_NONBLOCK because it allows us to make the distinction + between a true EOF and an EOF returned because there is no data + available to be read. */ + desc->slave_fd = open (desc->slave_name, O_RDWR | O_NONBLOCK, 0); +#else + desc->slave_fd = open (desc->slave_name, O_RDWR, 0); +#endif + +#if defined (sun) || defined (__hpux__) + /* On systems such as Solaris we are using stream. We need to push the right + "modules" in order to get the expected terminal behaviors. Otherwise + functionalities such as termios are not available. */ + ioctl (desc->slave_fd, I_PUSH, "ptem"); + ioctl (desc->slave_fd, I_PUSH, "ldterm"); + ioctl (desc->slave_fd, I_PUSH, "ttcompat"); +#endif + +#ifdef TIOCSCTTY + /* make the tty the controling terminal */ + status = ioctl (desc->slave_fd, TIOCSCTTY, 0); +#endif + + /* adjust tty settings */ + child_setup_tty (desc->slave_fd); + __gnat_setup_winsize (desc, 24, 80); /* To prevent errors in some shells */ + + /* stdin, stdout and stderr should be now our tty */ + dup2 (desc->slave_fd, 0); + dup2 (desc->slave_fd, 1); + dup2 (desc->slave_fd, 2); + if (desc->slave_fd > 2) close (desc->slave_fd); + + /* adjust process group settings */ + status = setpgid (pid, pid); + status = tcsetpgrp (0, pid); + + /* launch the program */ + execvp (new_argv[0], new_argv); + + /* return the pid */ + return pid; +} + +/* send_signal_via_characters - Send a characters that will trigger a signal + * in the child process. + * + * PARAMETERS + * desc a pty_desc structure containing terminal information + * int a signal number + * RETURN VALUE + * None + */ +static void +send_signal_via_characters + (pty_desc *desc, + int signal_number) +{ + char ctrl_c = 03; + char ctrl_backslash = 28; + char ctrl_Z = 26; + + switch (signal_number) + { + case SIGINT: + write (desc->master_fd, &ctrl_c, 1); return; + case SIGQUIT: + write (desc->master_fd, &ctrl_backslash, 1); return; + case SIGTSTP: + write (desc->master_fd, &ctrl_Z, 1); return; + } +} + +/* __gnat_interrupt_process - interrupt the child process + * + * PARAMETERS + * desc a pty_desc structure + */ +int +__gnat_interrupt_process (pty_desc *desc) +{ + send_signal_via_characters (desc, SIGINT); + return 0; +} + +/* __gnat_interrupt_pid - interrupt a process group + * + * PARAMETERS + * pid pid of the process to interrupt + */ +int +__gnat_interrupt_pid (int pid) +{ + kill (-pid, SIGINT); + return 0; +} + +/* __gnat_terminate_process - kill a child process + * + * PARAMETERS + * desc pty_desc structure + */ +int __gnat_terminate_process (pty_desc *desc) +{ + return kill (desc->child_pid, SIGKILL); +} + +/* __gnat_tty_waitpid - wait for the child proces to die + * + * PARAMETERS + * desc pty_desc structure + * RETURN VALUE + * exit status of the child process + */ +int +__gnat_tty_waitpid (pty_desc *desc) +{ + int status = 0; + waitpid (desc->child_pid, &status, 0); + return WEXITSTATUS (status); +} + +/* __gnat_tty_supported - Are tty supported ? + * + * RETURN VALUE + * always 1 on Unix systems + */ +int +__gnat_tty_supported (void) +{ + return 1; +} + +/* __gnat_free_process - free a pty_desc structure + * + * PARAMETERS + * in out desc: a pty desc structure + */ +void +__gnat_free_process (pty_desc** desc) +{ + free (*desc); + *desc = NULL; +} + +/* __gnat_send_header - dummy function. this interface is only used on Windows */ +void +__gnat_send_header (pty_desc* desc, char header[5], int size, int *ret) +{ + *ret = 0; +} + +/* __gnat_reset_tty - reset line setting + * + * PARAMETERS + * desc: a pty_desc structure + */ +void +__gnat_reset_tty (pty_desc* desc) +{ + child_setup_tty (desc->master_fd); +} + +/* __gnat_new_tty - allocate a new terminal + * + * RETURN VALUE + * a pty_desc structure + */ +pty_desc * +__gnat_new_tty (void) +{ + int status; + pty_desc* desc; + status = allocate_pty_desc (&desc); + child_setup_tty (desc->master_fd); + return desc; +} + +/* __gnat_close_tty - close a terminal + * + * PARAMETERS + * desc a pty_desc strucure + */ +void __gnat_close_tty (pty_desc* desc) +{ + if (desc->master_fd >= 0) close (desc->master_fd); + if (desc->slave_fd >= 0) close (desc->slave_fd); +} + +/* __gnat_tty_name - return slave side device name + * + * PARAMETERS + * desc a pty_desc strucure + * RETURN VALUE + * a string + */ +char * +__gnat_tty_name (pty_desc* desc) +{ + return desc->slave_name; +} + +/* __gnat_tty_name - return master side fd + * + * PARAMETERS + * desc a pty_desc strucure + * RETURN VALUE + * a fd + */ +int +__gnat_tty_fd (pty_desc* desc) +{ + return desc->master_fd; +} + +#endif /* WIN32 */ diff --git a/gcc/ada/thread.c b/gcc/ada/thread.c new file mode 100644 index 00000000000..a55accefef0 --- /dev/null +++ b/gcc/ada/thread.c @@ -0,0 +1,57 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * P T H R E A D * + * * + * C Implementation File * + * * + * Copyright (C) 2011, Free Software Foundation, Inc. * + * * + * GNAT is free software; you can redistribute it and/or modify it under * + * terms of the GNU General Public License as published by the Free Soft- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * <http://www.gnu.org/licenses/>. * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This file provides utility functions to access the threads API */ + +#include "s-oscons.h" + +#ifdef NEED_PTHREAD_CONDATTR_SETCLOCK +# include <pthread.h> +# include <time.h> + +int +__gnat_pthread_condattr_setup(pthread_condattr_t *attr) { +/* + * If using a clock other than CLOCK_REALTIME for the Ada Monotonic_Clock, + * the corresponding clock id must be set for condition variables. + */ + return pthread_condattr_setclock (attr, CLOCK_RT_Ada); +} + +#else + +int +__gnat_pthread_condattr_setup (void *attr) { + /* Dummy version for other platforms, which may or may not have pthread.h */ + return 0; +} + +#endif diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 05d3dbe1b9d..75a910d3301 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -102,12 +102,8 @@ package Types is -- Graphic characters, as defined in ARM subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; - -- Line terminator characters (LF, VT, FF, CR) - -- - -- This definition is dubious now that we have two more wide character - -- sequences that constitute a line terminator. Every reference to this - -- subtype needs checking to make sure the wide character case is handled - -- appropriately. ??? + -- Line terminator characters (LF, VT, FF, CR). For further details, + -- see the extensive discussion of line termination in the Sinput spec. subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index bfda0a73c56..9fc3d97d2e2 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -6200,6 +6200,14 @@ package VMS_Data is -- -- Set the maximum line length, nnn from 32 ..256. The default is 79. + S_Pretty_Maxact : aliased constant S := "/MAX_ACT=#" & + "--call_threshold=#"; + -- /MAX_ACT=nnn + -- + -- If the number of parameter associations is greater than nnn and if at + -- least one association uses named notation, start each association from + -- a new line + S_Pretty_Maxind : aliased constant S := "/MAX_INDENT=#" & "-T#"; -- /MAX_INDENT=nnn @@ -6209,6 +6217,14 @@ package VMS_Data is -- If nnn is zero, an additional indentation level is used for any -- number of case alternatives and variants. + S_Pretty_Maxpar : aliased constant S := "/MAX_PAR=#" & + "--par_threshold=#"; + -- /MAX_PAR=nnn + -- + -- If the number of parameter specifications is greater than nnn (or equal + -- to nnn in case of a function), start each specification from a new line. + -- The default value is 3. + S_Pretty_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & "DEFAULT " & "-vP0 " & @@ -6361,6 +6377,30 @@ package VMS_Data is -- of the directory specified in the project file. If the subdirectory -- does not exist, it is created automatically. + S_Pretty_Types : aliased constant S := "/TYPE_CASING=" & + "AS_DECLARED " & + "-ntD " & + "LOWER_CASE " & + "-ntL " & + "UPPER_CASE " & + "-ntU " & + "MIXED_CASE " & + "-ntM"; + -- /TYPE_CASING=name-option + -- + -- Specify the casing of type and subtype. If not specified, the + -- casing of these names is defined by the NAME_CASING option. + -- 'name-option' may be one of: + -- + -- AS_DECLARED Name casing for defining occurrences are + -- as they appear in the source file. + -- + -- LOWER_CASE Namess are in lower case. + -- + -- UPPER_CASE Namess are in upper case. + -- + -- MIXED_CASE Namess are in mixed case. + S_Pretty_Verbose : aliased constant S := "/VERBOSE " & "-v"; -- /NOVERBOSE (D) @@ -6401,7 +6441,9 @@ package VMS_Data is S_Pretty_Indent 'Access, S_Pretty_Keyword 'Access, S_Pretty_Maxlen 'Access, + S_Pretty_Maxact 'Access, S_Pretty_Maxind 'Access, + S_Pretty_Maxpar 'Access, S_Pretty_Mess 'Access, S_Pretty_Names 'Access, S_Pretty_No_Labels 'Access, @@ -6422,6 +6464,7 @@ package VMS_Data is S_Pretty_Stnm_On_Nw_Line 'Access, S_Pretty_Specific 'Access, S_Pretty_Standard 'Access, + S_Pretty_Types 'Access, S_Pretty_Verbose 'Access, S_Pretty_Warnings 'Access); |