diff options
Diffstat (limited to 'gcc/ada')
52 files changed, 3746 insertions, 1859 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7b8832d2992..69c2a847d78 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,319 @@ +2012-04-02 Robert Dewar <dewar@adacore.com> + + * s-atopri.ads: Minor reformatting. + +2012-04-02 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb: Minor reformatting, minor code cleanup. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * lib-xref.adb (Generate_Reference): For a reference to an + operator symbol, set the sloc to point to the first character + of the operator name, and not to the initial quaote. + (Output_References): Ditto for the definition of an operator + symbol. + +2012-04-02 Vincent Celier <celier@adacore.com> + + * ali.adb (Scan_Ali): Recognize Z lines. Set + Implicit_With_From_Instantiation to True in the With_Record for + Z lines. + * ali.ads (With_Record): New Boolean component + Implicit_With_From_Instantiation, defaulted to False. + * csinfo.adb: Indicate that Implicit_With_From_Instantiation + is special + * lib-writ.adb (Write_ALI): New array Implicit_With. + (Collect_Withs): Set Implicit_With for the unit is it is not Yes. + (Write_With_Lines): Write a Z line instead of a W line if + Implicit_With is Yes for the unit. + * sem_ch12.adb (Inherit_Context): Only add a unit in the context + if it is not there yet. + * sinfo.ads: New flag Implicit_With_From_Instantiation (Flag12) + added. + +2012-04-02 Yannick Moy <moy@adacore.com> + + * osint.adb, osint.ads (Add_Default_Search_Dirs): Add library + search dirs in file specified with option -gnateO. + +2012-04-02 Robert Dewar <dewar@adacore.com> + + * sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor + reformatting. + +2012-04-02 Olivier Hainque <hainque@adacore.com> + + * g-sse.ads: Add x86-solaris and x86_64-darwin to the set of + platforms where the use of this spec is supported. Add current + year to the copyright notice. + * gcc-interfaces/Makefile.in: Add g-sse.o and g-ssvety.o to + EXTRA_GNATRTL_NONTASKING_OBJS on x86 32/64 targets that support + it and where they were missing (x86-solaris, x86-freebsd, + x86_64-freebsd, and x86-darwin). + +2012-04-02 Gary Dismukes <dismukes@adacore.com> + + * bindgen.adb (Gen_Ada_Init): When compiling for the AAMP small + library, where we no longer suppress the Standard_Library, + generate an empty body rather than the usual generation of + assignments to imported globals, since those aren't present in + the small library. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads: Minor documentation fix. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Resolve_Conditional_Expression): Add local variables + Else_Typ and Then_Typ. Add missing type conversions to the "then" and + "else" expressions when their respective types are scalar. + +2012-04-02 Vincent Pucci <pucci@adacore.com> + + * exp_ch9.adb: Reordering of the local subprograms. New Table + for the lock free implementation that maps each protected + subprograms with the protected component it references. + (Allow_Lock_Free_Implementation): New routine. Check if + the protected body enables the lock free implementation. + (Build_Lock_Free_Protected_Subprogram_Body): New routine. + (Build_Lock_Free_Unprotected_Subprogram_Body): New routine. + (Comp_Of): New routine. + * Makefile.rtl: Add s-atopri.o + * debug.adb: New compiler debug flag -gnatd9 for lock free + implementation. + * rtsfind.ads: RE_Atomic_Compare_Exchange_8, + RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32, + RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8, + RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, RE_Uint8, + RE_Uint16, RE_Uint32, RE_Uint64 added. + * s-atropi.ads: New file. Defines atomic primitives used + by the lock free implementation. + +2012-04-02 Emmanuel Briot <briot@adacore.com> + + * g-expect.adb (Expect_Internal): Fix leak of the input file descriptor. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Expand_N_Quantified_Expression): Reimplemented. + The expansion no longer uses the copy of the original QE created + during analysis. + * sem.adb (Analyze): Add processing for loop parameter specifications. + * sem_ch4.adb (Analyze_Quantified_Expression): Reimplemented. The + routine no longer creates a copy of the original QE. All + constituents of a QE are now preanalyzed and resolved. + * sem_ch5.adb (Analyze_Iteration_Scheme): Remove the guard which + bypasses all processing when the iteration scheme is related to a + QE. Relovate the code which analyzes loop parameter specifications + to a separate routine. (Analyze_Iterator_Specification): + Preanalyze the iterator name. This action was originally + done in Analyze_Iteration_Scheme. Update the check which + detects an iterator specification in the context of a QE. + (Analyze_Loop_Parameter_Specification): New routine. This + procedure allows for a stand-alone analysis of a loop parameter + specification without the need of a parent iteration scheme. Add + code to update the type of the loop variable when the range + generates an itype and the context is a QE. + (Pre_Analyze_Range): Renamed to Preanalyze_Range. Update all references + to the routine. + * sem_ch5.ads: Code reformatting. + (Analyze_Loop_Parameter_Specification): New routine. + * sem_ch6.adb (Fully_Conformant_Expressions): Detect a case + when establishing conformance between two QEs utilizing different + specifications. + * sem_res.adb (Proper_Current_Scope): New routine. + (Resolve): Do not resolve a QE as there is nothing to be done now. + Ignore any loop scopes generated for QEs when detecting an expression + function as the scopes are cosmetic and do not appear in the tree. + (Resolve_Quantified_Expression): Removed. All resolution of + QE constituents is now performed during analysis. This ensures + that loop variables appearing in array aggregates are properly + resolved. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Build_Default_Subtype): If the base type is + private and its full view is available, use the full view in + the subtype declaration. + +2012-04-02 Jose Ruiz <ruiz@adacore.com> + + * gnat_ugn.texi: Add some minimal documentation about how to + use GNATtest for cross platforms. + +2012-04-02 Vincent Celier <celier@adacore.com> + + * opt.ads (Object_Path_File_Name): New variable. + * prj-attr.adb: New Compiler attribute Object_Path_Switches. + * prj-nmsc.adb (Process_Compiler): Recognize new attribute + Object_Path_Switches. + * snames.ads-tmpl: New standard name Object_Path_Switches. + * switch-c.adb (Scan_Front_End_Switches): Recognize new switch + -gnateO= and put its value in Opt.Object_Path_File_Name. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Process_Declarations): Detect a case where + a source object was initialized by another source object, + but the expression was rewritten as a class-wide conversion + of Ada.Tags.Displace. + * exp_util.adb (Initialized_By_Ctrl_Function): Removed. + (Is_Controlled_Function_Call): New routine. + (Is_Displacement_Of_Ctrl_Function_Result): Removed. + (Is_Displacement_Of_Object_Or_Function_Result): New routine. + (Is_Source_Object): New routine. + (Requires_Cleanup_Actions): Detect a case where a source object was + initialized by another source object, but the expression was rewritten + as a class-wide conversion of Ada.Tags.Displace. + * exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): Removed. + (Is_Displacement_Of_Object_Or_Function_Result): New routine. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Call): A call to an expression function + does not freeze if it appears in a different scope from the + expression function itself. Such calls appear in the generated + bodies of other expression functions, or in pre/postconditions + of subsequent subprograms. + +2012-04-02 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb: Code clean up. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Do not suppress + style checks, because the subprogram instance itself may contain + violations of syle rules. + * style.adb (Missing_Overriding): Check for missing overriding + indicator on a subprogram instance. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Last_Implicit_Declaration): New routine. + (Process_PPCs): Insert the body of _postconditions after the + last internally generated declaration. This ensures that actual + subtypes created for formal parameters are visible and properly + frozen as _postconditions may reference them. + +2012-04-02 Robert Dewar <dewar@adacore.com> + + * einfo.adb (First_Component_Or_Discriminant) Now applies to + all types with discriminants, not just records. + * exp_attr.adb (Expand_N_Attribute): Add Scalar_Values handling + for arrays, scalars and non-variant records. + * sem_attr.adb (Analyze_Attribute): Handle Valid_Scalars + * sem_attr.ads (Valid_Scalars): Update description + * sem_util.ads, sem_util.adb (No_Scalar_Parts): New function. + +2012-03-31 Eric Botcazou <ebotcazou@adacore.com> + + Revert + 2012-03-25 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (SS_MARK_NAME): New define. + (gnat_to_gnu_entity) <E_Function>: Prepend leaf attribute on entities + whose name is SS_MARK_NAME. + +2012-03-30 Robert Dewar <dewar@adacore.com> + + * exp_ch5.adb, sem_util.adb, exp_ch4.adb: Minor comment updates. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Add_Alfa_File): Treat possibly 2 units at the same + time, putting all scopes in the same Alfa file. + (Add_Alfa_Xrefs): Correct errors in comparison function. Correct value + of Def component. + (Collect_Alfa): Possibly pass 2 units to Add_Alfa_File. + +2012-03-30 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb (Is_Secondary_Stack_BIP_Func_Call): Handle a case where + a build-in-place call appears as Prefix'Reference'Reference. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb: Minor refactoring to remove internal package. + +2012-03-30 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch5.adb (Analyze_Iteration_Scheme): Preanalyze the subtype + definition of a loop when the context is a quantified expression. + +2012-03-30 Vincent Celier <celier@adacore.com> + + * prj.ads: Minor comment update. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb, alloc.ads, lib-xref.ads: Minor addition of + comments and refactoring. + +2012-03-30 Robert Dewar <dewar@adacore.com> + + * lib-xref.adb, lib-xref-alfa.adb: Minor reformatting & code + reorganization. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Generate_Dereference): Use Get_Code_Unit + instead of Get_Source_Unit to get file for reference. + (Traverse_Compilation_Unit): Do not add scopes for generic units. + * lib-xref.adb (Generate_Reference): Use Get_Code_Unit instead + of Get_Source_Unit to get file for reference. + * sem_ch12.adb (Analyze_Package_Instantiation): Enable + instantiation in Alfa mode. + +2012-03-30 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Process_Declarations): Replace + the call to Is_Null_Access_BIP_Func_Call with + Is_Secondary_Stack_BIP_Func_Call. Update the related comment. + * exp_util.adb (Is_Null_Access_BIP_Func_Call): Removed. + (Is_Secondary_Stack_BIP_Func_Call): New routine. + (Requires_Cleanup_Actions): Replace + the call to Is_Null_Access_BIP_Func_Call with + Is_Secondary_Stack_BIP_Func_Call. Update the related comment. + * exp_util.ads (Is_Null_Access_BIP_Func_Call): Removed. + (Is_Secondary_Stack_BIP_Func_Call): New routine. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb, lib-xref.adb: Code clean ups. + +2012-03-30 Gary Dismukes <dismukes@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): For the case of a + loop entity which is rewritten as a renaming + of the indexed array, explicitly mark the entity as needing + debug info so that Materialize entity will be set later by + Debug_Renaming_Declaration when the renaming is expanded. + +2012-03-30 Robert Dewar <dewar@adacore.com> + + * sem_attr.ads: Update comment. + +2012-03-30 Vincent Celier <celier@adacore.com> + + * prj.ads: New Dependency_Kind: ALI_Closure. + +2012-03-30 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb: Minor reformatting. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Add_Alfa_File): Take into account possible absence + of compilation unit for unit in Sdep_Table. + +2012-03-30 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Freeze_Record_Type): For a type with reversed bit + order and reversed storage order, disable front-end relayout. + 2012-03-25 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Copy diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 71696585458..d3212b20559 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -479,6 +479,7 @@ GNATRTL_NONTASKING_OBJS= \ s-assert$(objext) \ s-atacco$(objext) \ s-atocou$(objext) \ + s-atopri$(objext) \ s-auxdec$(objext) \ s-bitops$(objext) \ s-boarop$(objext) \ diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 93dd10956cc..28307ac72a4 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -55,6 +55,7 @@ package body ALI is 'X' => True, -- xref 'S' => True, -- specific dispatching 'Y' => True, -- limited_with + 'Z' => True, -- implicit with from instantiation 'C' => True, -- SCO information 'F' => True, -- Alfa information others => False); @@ -782,7 +783,8 @@ package body ALI is -- Acquire lines to be ignored if Read_Xref then - Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True); + Ignore := + ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); -- Read_Lines parameter given @@ -1717,7 +1719,7 @@ package body ALI is With_Loop : loop Check_Unknown_Line; - exit With_Loop when C /= 'W' and then C /= 'Y'; + exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z'; if Ignore ('W') then Skip_Line; @@ -1733,6 +1735,8 @@ package body ALI is Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).SAL_Interface := False; Withs.Table (Withs.Last).Limited_With := (C = 'Y'); + Withs.Table (Withs.Last).Implicit_With_From_Instantiation + := (C = 'Z'); -- Generic case with no object file available diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index b2b9b3d7ffc..39943c4fcc7 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -558,6 +558,9 @@ package ALI is Limited_With : Boolean := False; -- True if unit is named in a limited_with_clause + + Implicit_With_From_Instantiation : Boolean := False; + -- True if this is an implicit with from a generic instantiation end record; package Withs is new Table.Table ( diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index c5cad729652..18a2be62157 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -157,4 +157,7 @@ package Alloc is Xrefs_Initial : constant := 5_000; -- Cross-refs Xrefs_Increment : constant := 300; + Drefs_Initial : constant := 5; -- Dereferences + Drefs_Increment : constant := 1_000; + end Alloc; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index a4b7d394deb..c44a648e210 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -511,6 +511,14 @@ package body Bindgen is if CodePeer_Mode then WBI (" begin"); + -- When compiling for the AAMP small library, where the standard library + -- is no longer suppressed, we still want to exclude the setting of the + -- various imported globals, which aren't present for that library. + + elsif AAMP_On_Target and then Configurable_Run_Time_On_Target then + WBI (" begin"); + WBI (" null;"); + -- If the standard library is suppressed, then the only global variables -- that might be needed (by the Ravenscar profile) are the priority and -- the processor for the environment task. diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb index ef319cff9e5..024af66479c 100644 --- a/gcc/ada/csinfo.adb +++ b/gcc/ada/csinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -218,6 +218,7 @@ begin Set (Special, "Has_Dynamic_Range_Check", True); Set (Special, "Has_Dynamic_Length_Check", True); Set (Special, "Has_Private_View", True); + Set (Special, "Implicit_With_From_Instantiation", True); Set (Special, "Is_Controlling_Actual", True); Set (Special, "Is_Overloaded", True); Set (Special, "Is_Static_Expression", True); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index bb3e4857ad5..cbcdf0cbb51 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -153,7 +153,7 @@ package body Debug is -- d6 Default access unconstrained to thin pointers -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode -- d8 Force opposite endianness in packed stuff - -- d9 + -- d9 Allow lock free implementation -- Debug flags for binder (GNATBIND) @@ -710,6 +710,9 @@ package body Debug is -- opposite endianness from the actual correct value. Useful in -- testing out code generation from the packed routines. + -- d9 This allows lock free implementation for protected objects + -- (see Exp_Ch9). + ------------------------------------------ -- Documentation for Binder Debug Flags -- ------------------------------------------ diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 0fdc83c3086..0f597a1f941 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5880,7 +5880,9 @@ package body Einfo is begin pragma Assert - (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); + (Is_Record_Type (Id) + or else Is_Incomplete_Or_Private_Type (Id) + or else Has_Discriminants (Id)); Comp_Id := First_Entity (Id); while Present (Comp_Id) loop diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b8058ae2442..355770186db 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -76,6 +76,14 @@ package body Exp_Attr is -- Local Subprograms -- ----------------------- + function Build_Array_VS_Func + (A_Type : Entity_Id; + Nod : Node_Id) return Entity_Id; + -- Build function to test Valid_Scalars for array type A_Type. Nod is the + -- Valid_Scalars attribute node, used to insert the function body, and the + -- value returned is the entity of the constructed function body. We do not + -- bother to generate a separate spec for this subprogram. + procedure Compile_Stream_Body_In_Scope (N : Node_Id; Decl : Node_Id; @@ -174,6 +182,149 @@ package body Exp_Attr is -- expansion. Typically used for rounding and truncation attributes that -- appear directly inside a conversion to integer. + ------------------------- + -- Build_Array_VS_Func -- + ------------------------- + + function Build_Array_VS_Func + (A_Type : Entity_Id; + Nod : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Body_Stmts : List_Id; + Index_List : List_Id; + Func_Id : Entity_Id; + Formals : List_Id; + + function Test_Component return List_Id; + -- Create one statement to test validity of one component designated by + -- a full set of indexes. Returns statement list containing test. + + function Test_One_Dimension (N : Int) return List_Id; + -- Create loop to test one dimension of the array. The single statement + -- in the loop body tests the inner dimensions if any, or else the + -- single component. Note that this procedure is called recursively, + -- with N being the dimension to be initialized. A call with N greater + -- than the number of dimensions simply generates the component test, + -- terminating the recursion. Returns statement list containing tests. + + -------------------- + -- Test_Component -- + -------------------- + + function Test_Component return List_Id is + Comp : Node_Id; + Anam : Name_Id; + + begin + Comp := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uA), + Expressions => Index_List); + + if Is_Scalar_Type (Comp_Type) then + Anam := Name_Valid; + else + Anam := Name_Valid_Scalars; + end if; + + return New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Anam, + Prefix => Comp)), + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc))))); + end Test_Component; + + ------------------------ + -- Test_One_Dimension -- + ------------------------ + + function Test_One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + -- If all dimensions dealt with, we simply test the component + + if N > Number_Dimensions (A_Type) then + return Test_Component; + + -- Here we generate the required loop + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uA), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))))), + Statements => Test_One_Dimension (N + 1)), + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_True, Loc))); + end if; + end Test_One_Dimension; + + -- Start of processing for Build_Array_VS_Func + + begin + Index_List := New_List; + Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + + Body_Stmts := Test_One_Dimension (1); + + -- Parameter is always (A : A_Typ) + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA), + In_Present => True, + Out_Present => False, + Parameter_Type => New_Reference_To (A_Type, Loc))); + + -- Build body + + Set_Ekind (Func_Id, E_Function); + Set_Is_Internal (Func_Id); + + Insert_Action (Nod, + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Id, + Parameter_Specifications => Formals, + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts))); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + return Func_Id; + end Build_Array_VS_Func; + ---------------------------------- -- Compile_Stream_Body_In_Scope -- ---------------------------------- @@ -5373,8 +5524,89 @@ package body Exp_Attr is ------------------- when Attribute_Valid_Scalars => Valid_Scalars : declare + Ftyp : Entity_Id; + begin - raise Program_Error; + if Present (Underlying_Type (Ptyp)) then + Ftyp := Underlying_Type (Ptyp); + else + Ftyp := Ptyp; + end if; + + -- For scalar types, Valid_Scalars is the same as Valid + + if Is_Scalar_Type (Ftyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Valid, + Prefix => Pref)); + Analyze_And_Resolve (N, Standard_Boolean); + + -- For array types, we construct a function that determines if there + -- are any non-valid scalar subcomponents, and call the function. + -- We only do this for arrays whose component type needs checking + + elsif Is_Array_Type (Ftyp) + and then not No_Scalar_Parts (Component_Type (Ftyp)) + then + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc), + Parameter_Associations => New_List (Pref))); + + Analyze_And_Resolve (N, Standard_Boolean); + + -- For record types, we build a big conditional expression, applying + -- Valid or Valid_Scalars as appropriate to all relevant components. + + elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp)) + and then not No_Scalar_Parts (Ptyp) + then + declare + C : Entity_Id; + X : Node_Id; + A : Name_Id; + + begin + X := New_Occurrence_Of (Standard_True, Loc); + C := First_Component_Or_Discriminant (Ptyp); + while Present (C) loop + if No_Scalar_Parts (Etype (C)) then + goto Continue; + elsif Is_Scalar_Type (Etype (C)) then + A := Name_Valid; + else + A := Name_Valid_Scalars; + end if; + + X := + Make_And_Then (Loc, + Left_Opnd => X, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => A, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr (Pref, Name_Req => True), + Selector_Name => + New_Occurrence_Of (C, Loc)))); + <<Continue>> + Next_Component_Or_Discriminant (C); + end loop; + + Rewrite (N, X); + Analyze_And_Resolve (N, Standard_Boolean); + end; + + -- For all other types, result is True (but not static) + + else + Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + Set_Is_Static_Expression (N, False); + end if; end Valid_Scalars; ----------- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d04512ad5e1..02a733cee88 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -3072,7 +3072,7 @@ package body Exp_Ch4 is Low_Bound := Opnd_Low_Bound (1); -- OK, we don't know the lower bound, we have to build a horrible - -- expression actions node of the form + -- conditional expression node of the form -- if Cond1'Length /= 0 then -- Opnd1 low bound @@ -3998,9 +3998,9 @@ package body Exp_Ch4 is end if; end; - -- We set the allocator as analyzed so that when we analyze the - -- expression actions node, we do not get an unwanted recursive - -- expansion of the allocator expression. + -- We set the allocator as analyzed so that when we analyze + -- the conditional expression node, we do not get an unwanted + -- recursive expansion of the allocator expression. Set_Analyzed (N, True); Nod := Relocate_Node (N); @@ -4279,7 +4279,7 @@ package body Exp_Ch4 is -- Expand_N_Conditional_Expression -- ------------------------------------- - -- Deal with limited types and expression actions + -- Deal with limited types and condition actions procedure Expand_N_Conditional_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -7832,9 +7832,7 @@ package body Exp_Ch4 is begin -- Do validity check if validity checking operands - if Validity_Checks_On - and then Validity_Check_Operands - then + if Validity_Checks_On and then Validity_Check_Operands then Ensure_Valid (Operand); end if; @@ -7866,7 +7864,7 @@ package body Exp_Ch4 is -- end if; -- end loop; - -- Conversely, an existentially quantified expression: + -- Similarly, an existentially quantified expression: -- for some X in range => Cond @@ -7884,75 +7882,79 @@ package body Exp_Ch4 is -- given by an iterator specification, not a loop parameter specification. procedure Expand_N_Quantified_Expression (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Is_Universal : constant Boolean := All_Present (N); - Actions : constant List_Id := New_List; - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Cond : Node_Id; - Decl : Node_Id; - I_Scheme : Node_Id; - Original_N : Node_Id; - Test : Node_Id; + Actions : constant List_Id := New_List; + For_All : constant Boolean := All_Present (N); + Iter_Spec : constant Node_Id := Iterator_Specification (N); + Loc : constant Source_Ptr := Sloc (N); + Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); + Cond : Node_Id; + Flag : Entity_Id; + Scheme : Node_Id; + Stmts : List_Id; begin - -- Retrieve the original quantified expression (non analyzed) + -- Create the declaration of the flag which tracks the status of the + -- quantified expression. Generate: - if Present (Loop_Parameter_Specification (N)) then - Original_N := Parent (Parent (Loop_Parameter_Specification (N))); - else - Original_N := Parent (Parent (Iterator_Specification (N))); - end if; + -- Flag : Boolean := (True | False); - -- Rewrite N with the original quantified expression + Flag := Make_Temporary (Loc, 'T', N); - Rewrite (N, Original_N); - - Decl := + Append_To (Actions, Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, + Defining_Identifier => Flag, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => - New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc)); - Append_To (Actions, Decl); + New_Occurrence_Of (Boolean_Literals (For_All), Loc))); + + -- Construct the circuitry which tracks the status of the quantified + -- expression. Generate: + + -- if [not] Cond then + -- Flag := (False | True); + -- exit; + -- end if; Cond := Relocate_Node (Condition (N)); - if Is_Universal then + if For_All then Cond := Make_Op_Not (Loc, Cond); end if; - Test := + Stmts := New_List ( Make_Implicit_If_Statement (N, Condition => Cond, Then_Statements => New_List ( Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Tnn, Loc), + Name => New_Occurrence_Of (Flag, Loc), Expression => - New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)), - Make_Exit_Statement (Loc))); + New_Occurrence_Of (Boolean_Literals (not For_All), Loc)), + Make_Exit_Statement (Loc)))); - if Present (Loop_Parameter_Specification (N)) then - I_Scheme := + -- Build the loop equivalent of the quantified expression + + if Present (Iter_Spec) then + Scheme := Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Loop_Parameter_Specification (N)); + Iterator_Specification => Iter_Spec); else - I_Scheme := + Scheme := Make_Iteration_Scheme (Loc, - Iterator_Specification => Iterator_Specification (N)); + Loop_Parameter_Specification => Loop_Spec); end if; Append_To (Actions, Make_Loop_Statement (Loc, - Iteration_Scheme => I_Scheme, - Statements => New_List (Test), + Iteration_Scheme => Scheme, + Statements => Stmts, End_Label => Empty)); + -- Transform the quantified expression + Rewrite (N, Make_Expression_With_Actions (Loc, - Expression => New_Occurrence_Of (Tnn, Loc), + Expression => New_Occurrence_Of (Flag, Loc), Actions => Actions)); - Analyze_And_Resolve (N, Standard_Boolean); end Expand_N_Quantified_Expression; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 6d00dc806ae..82fc705ecff 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2777,7 +2777,7 @@ package body Exp_Ch5 is end loop; -- Loop through elsif parts, dealing with constant conditions and - -- possible expression actions that are present. + -- possible condition actions that are present. if Present (Elsif_Parts (N)) then E := First (Elsif_Parts (N)); @@ -3303,6 +3303,14 @@ package body Exp_Ch5 is New_Reference_To (Component_Type (Array_Typ), Loc), Name => Ind_Comp)); + -- Mark the loop variable as needing debug info, so that expansion + -- of the renaming will result in Materialize_Entity getting set via + -- Debug_Renaming_Declaration. (This setting is needed here because + -- the setting in Freeze_Entity comes after the expansion, which is + -- too late. ???) + + Set_Debug_Info_Needed (Id); + -- for Index in Array loop -- This case utilizes the already given iterator name diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0347dcc5bd7..f8730f3d9ab 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1824,15 +1824,14 @@ package body Exp_Ch7 is -- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- Obj : Access_Typ := - -- BIP_Function_Call - -- (..., BIPaccess => null, ...)'reference; + -- BIP_Function_Call (BIPalloc => 2, ...)'reference; elsif Is_Access_Type (Obj_Typ) and then Needs_Finalization (Available_View (Designated_Type (Obj_Typ))) and then Present (Expr) and then - (Is_Null_Access_BIP_Func_Call (Expr) + (Is_Secondary_Stack_BIP_Func_Call (Expr) or else (Is_Non_BIP_Func_Call (Expr) and then not Is_Related_To_Func_Return (Obj_Id))) @@ -1918,16 +1917,17 @@ package body Exp_Ch7 is Processing_Actions (Has_No_Init => True); -- Detect a case where a source object has been initialized by - -- a controlled function call which was later rewritten as a - -- class-wide conversion of Ada.Tags.Displace. + -- a controlled function call or another object which was later + -- rewritten as a class-wide conversion of Ada.Tags.Displace. - -- Obj : Class_Wide_Type := Function_Call (...); + -- Obj1 : CW_Type := Src_Obj; + -- Obj2 : CW_Type := Function_Call (...); - -- Temp : ... := Function_Call (...)'reference; - -- Obj : Class_Wide_Type renames - -- (... Ada.Tags.Displace (Temp)); + -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); + -- Tmp : ... := Function_Call (...)'reference; + -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); - elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then + elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then Processing_Actions (Has_No_Init => True); end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index a827284ff63..212ed30cebd 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -60,6 +61,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -75,6 +77,34 @@ package body Exp_Ch9 is Entry_Family_Bound : constant Int := 2**16; + ------------------------------ + -- Lock Free Data Structure -- + ------------------------------ + + -- A data structure used for the Lock Free (LF) implementation of protected + -- objects. Since a protected subprogram can only access a single protected + -- component in the LF implementation, this structure stores each protected + -- subprogram and its accessed protected component when the protected + -- object allows the LF implementation. + + type Lock_Free_Sub_Type is record + Sub_Body : Node_Id; + Comp_Id : Entity_Id; + end record; + + subtype Subprogram_Id is Nat; + + -- The following table used for the Lock Free implementation of protected + -- objects maps Lock_Free_Sub_Type to Subprogram_Id. + + package LF_Sub_Table is new Table.Table ( + Table_Component_Type => Lock_Free_Sub_Type, + Table_Index_Type => Subprogram_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 5, + Table_Name => "LF_Sub_Table"); + ----------------------- -- Local Subprograms -- ----------------------- @@ -109,6 +139,10 @@ package body Exp_Ch9 is -- Decls is the list of declarations to be enhanced. -- Ent is the entity for the original entry body. + function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean; + -- Given a protected body N, return True if N permits a lock free + -- implementation. + function Build_Accept_Body (Astat : Node_Id) return Node_Id; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in @@ -144,6 +178,32 @@ package body Exp_Ch9 is -- of the range of each entry family. A single array with that size is -- allocated for each concurrent object of the type. + function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; + -- Build the function that translates the entry index in the call + -- (which depends on the size of entry families) into an index into the + -- Entry_Bodies_Array, to determine the body and barrier function used + -- in a protected entry call. A pointer to this function appears in every + -- protected object. + + function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; + -- Build subprogram declaration for previous one + + function Build_Lock_Free_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) return Node_Id; + -- This function is used to construct the lock free version of a protected + -- subprogram when the protected type denoted by Pid allows the lock free + -- implementation. It only contains a call to the unprotected version of + -- the subprogram body. + + function Build_Lock_Free_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) return Node_Id; + -- This function is used to construct the lock free version of an + -- unprotected subprogram when the protected type denoted by Pid allows the + -- lock free implementation. + function Build_Parameter_Block (Loc : Source_Ptr; Actuals : List_Id; @@ -169,49 +229,6 @@ package body Exp_Ch9 is -- and Decl is the enclosing synchronized type declaration at whose -- freeze point the generated body is analyzed. - function Build_Renamed_Formal_Declaration - (New_F : Entity_Id; - Formal : Entity_Id; - Comp : Entity_Id; - Renamed_Formal : Node_Id) return Node_Id; - -- Create a renaming declaration for a formal, within a protected entry - -- body or an accept body. The renamed object is a component of the - -- parameter block that is a parameter in the entry call. - - -- In Ada 2012, if the formal is an incomplete tagged type, the renaming - -- does not dereference the corresponding component to prevent an illegal - -- use of the incomplete type (AI05-0151). - - procedure Build_Wrapper_Bodies - (Loc : Source_Ptr; - Typ : Entity_Id; - N : Node_Id); - -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding - -- record of a concurrent type. N is the insertion node where all bodies - -- will be placed. This routine builds the bodies of the subprograms which - -- serve as an indirection mechanism to overriding primitives of concurrent - -- types, entries and protected procedures. Any new body is analyzed. - - procedure Build_Wrapper_Specs - (Loc : Source_Ptr; - Typ : Entity_Id; - N : in out Node_Id); - -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding - -- record of a concurrent type. N is the insertion node where all specs - -- will be placed. This routine builds the specs of the subprograms which - -- serve as an indirection mechanism to overriding primitives of concurrent - -- types, entries and protected procedures. Any new spec is analyzed. - - function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; - -- Build the function that translates the entry index in the call - -- (which depends on the size of entry families) into an index into the - -- Entry_Bodies_Array, to determine the body and barrier function used - -- in a protected entry call. A pointer to this function appears in every - -- protected object. - - function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; - -- Build subprogram declaration for previous one - function Build_Protected_Entry (N : Node_Id; Ent : Entity_Id; @@ -252,6 +269,19 @@ package body Exp_Ch9 is -- a cleanup handler that unlocks the object in all cases. -- (see Exp_Ch7.Expand_Cleanup_Actions). + function Build_Renamed_Formal_Declaration + (New_F : Entity_Id; + Formal : Entity_Id; + Comp : Entity_Id; + Renamed_Formal : Node_Id) return Node_Id; + -- Create a renaming declaration for a formal, within a protected entry + -- body or an accept body. The renamed object is a component of the + -- parameter block that is a parameter in the entry call. + -- + -- In Ada 2012, if the formal is an incomplete tagged type, the renaming + -- does not dereference the corresponding component to prevent an illegal + -- use of the incomplete type (AI05-0151). + function Build_Selected_Name (Prefix : Entity_Id; Selector : Entity_Id; @@ -291,6 +321,26 @@ package body Exp_Ch9 is -- subprogram that is called from all protected operations on the same -- object, including the protected version of the same subprogram. + procedure Build_Wrapper_Bodies + (Loc : Source_Ptr; + Typ : Entity_Id; + N : Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all bodies + -- will be placed. This routine builds the bodies of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new body is analyzed. + + procedure Build_Wrapper_Specs + (Loc : Source_Ptr; + Typ : Entity_Id; + N : in out Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all specs + -- will be placed. This routine builds the specs of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new spec is analyzed. + procedure Collect_Entry_Families (Loc : Source_Ptr; Cdecls : List_Id; @@ -299,6 +349,10 @@ package body Exp_Ch9 is -- For each entry family in a concurrent type, create an anonymous array -- type of the right size, and add a component to the corresponding_record. + function Comp_Of (Sub_Body : Node_Id) return Entity_Id; + -- For the lock free implementation, return the protected component entity + -- referenced in Sub_Body using LF_Sub_Table. + function Concurrent_Object (Spec_Id : Entity_Id; Conc_Typ : Entity_Id) return Entity_Id; @@ -322,6 +376,26 @@ package body Exp_Ch9 is -- step of the expansion must to be done after private data has been moved -- to its final resting scope to ensure proper visibility of debug objects. + procedure Extract_Dispatching_Call + (N : Node_Id; + Call_Ent : out Entity_Id; + Object : out Entity_Id; + Actuals : out List_Id; + Formals : out List_Id); + -- Given a dispatching call, extract the entity of the name of the call, + -- its actual dispatching object, its actual parameters and the formal + -- parameters of the overridden interface-level version. If the type of + -- the dispatching object is an access type then an explicit dereference + -- is returned in Object. + + procedure Extract_Entry + (N : Node_Id; + Concval : out Node_Id; + Ename : out Node_Id; + Index : out Node_Id); + -- Given an entry call, returns the associated concurrent object, + -- the entry name, and the entry family index. + function Family_Offset (Loc : Source_Ptr; Hi : Node_Id; @@ -358,26 +432,6 @@ package body Exp_Ch9 is -- the scope of Context_Id and Context_Decls is the declarative list of -- Context. - procedure Extract_Dispatching_Call - (N : Node_Id; - Call_Ent : out Entity_Id; - Object : out Entity_Id; - Actuals : out List_Id; - Formals : out List_Id); - -- Given a dispatching call, extract the entity of the name of the call, - -- its actual dispatching object, its actual parameters and the formal - -- parameters of the overridden interface-level version. If the type of - -- the dispatching object is an access type then an explicit dereference - -- is returned in Object. - - procedure Extract_Entry - (N : Node_Id; - Concval : out Node_Id; - Ename : out Node_Id; - Index : out Node_Id); - -- Given an entry call, returns the associated concurrent object, - -- the entry name, and the entry family index. - function Find_Task_Or_Protected_Pragma (T : Node_Id; P : Name_Id) return Node_Id; @@ -393,6 +447,9 @@ package body Exp_Ch9 is -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal -- parameter _E. + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; + -- Tell whether a given subprogram cannot raise an exception + function Is_Potentially_Large_Family (Base_Index : Entity_Id; Conctyp : Entity_Id; @@ -762,6 +819,263 @@ package body Exp_Ch9 is Prepend_To (Decls, Decl); end Add_Object_Pointer; + ------------------------------------ + -- Allow_Lock_Free_Implementation -- + ------------------------------------ + + -- Here are the restrictions for the Lock Free implementation + + -- Implementation Restrictions on protected declaration + + -- There must be only protected scalar components (at least one) + + -- Component types must support an atomic compare_exchange primitive + -- (size equals to 1, 2, 4 or 8 bytes). + + -- No entries + + -- Implementation Restrictions on protected operations + + -- Cannot refer to non-constant outside of the scope of the protected + -- operation. + + -- Can only access a single protected component: all protected + -- component names appearing in a scope (including nested scopes) + -- must statically denote the same protected component. + + -- Fundamental Restrictions on protected operations + + -- No loop and procedure call statements + + -- Any function call and attribute reference must be static + + function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean is + Decls : constant List_Id := Declarations (N); + Spec : constant Entity_Id := Corresponding_Spec (N); + Pro_Def : constant Node_Id := Protected_Definition (Parent (Spec)); + Pri_Decls : constant List_Id := Private_Declarations (Pro_Def); + Vis_Decls : constant List_Id := Visible_Declarations (Pro_Def); + + Comp_Id : Entity_Id; + Comp_Size : Int; + Comp_Type : Entity_Id; + No_Component : Boolean := True; + N_Decl : Node_Id; + + function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean; + -- Return True if the protected subprogram body Sub_Body doesn't + -- prevent the lock free code expansion, i.e. Sub_Body meets all the + -- restrictions listed below that allow the lock free implementation. + -- + -- Can only access a single protected component + -- + -- No loop and procedure call statements + + -- Any function call and attribute reference must be static + + -- Cannot refer to non-constant outside of the scope of the protected + -- subprogram. + + ---------------------- + -- Permit_Lock_Free -- + ---------------------- + + function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean is + Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body); + Comp_Id : Entity_Id := Empty; + LF_Sub : Lock_Free_Sub_Type; + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Check the node N meet the lock free restrictions + + function Check_All_Nodes is new Traverse_Func (Check_Node); + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + Comp_Decl : Node_Id; + Id : Entity_Id; + + begin + case Nkind (N) is + + -- Function call or attribute reference case + + when N_Function_Call | N_Attribute_Reference => + + -- Any function call and attribute reference must be static + + if not Is_Static_Expression (N) then + return Abandon; + end if; + + -- Loop and procedure call statement case + + when N_Procedure_Call_Statement | N_Loop_Statement => + -- No loop and procedure call statements + return Abandon; + + -- Identifier case + + when N_Identifier => + if Present (Entity (N)) then + Id := Entity (N); + + -- Cannot refer to non-constant entities outside of the + -- scope of the protected subprogram. + + if Ekind (Id) in Assignable_Kind + and then Sloc (Scope (Id)) > No_Location + and then not Scope_Within_Or_Same (Scope (Id), Sub_Id) + and then not Scope_Within_Or_Same (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + return Abandon; + end if; + + -- Can only access a single protected component + + if Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id)) + then + Comp_Decl := Parent (Prival_Link (Id)); + + if Nkind (Comp_Decl) = N_Component_Declaration + and then Is_List_Member (Comp_Decl) + and then List_Containing (Comp_Decl) = Pri_Decls + then + -- Check if another protected component has already + -- been accessed by the subprogram body. + + if Present (Comp_Id) + and then Comp_Id /= Prival_Link (Id) + then + return Abandon; + + elsif not Present (Comp_Id) then + Comp_Id := Prival_Link (Id); + end if; + end if; + end if; + end if; + + -- Ok for all other nodes + + when others => return OK; + end case; + + return OK; + end Check_Node; + + -- Start of processing for Permit_Lock_Free + + begin + if Check_All_Nodes (Sub_Body) = OK then + + -- Fill LF_Sub with Sub_Body and its corresponding protected + -- component entity and then store LF_Sub in the lock free + -- subprogram table LF_Sub_Table. + + LF_Sub.Sub_Body := Sub_Body; + LF_Sub.Comp_Id := Comp_Id; + LF_Sub_Table.Append (LF_Sub); + return True; + + else + return False; + end if; + end Permit_Lock_Free; + + -- Start of processing for Allow_Lock_Free_Implementation + + begin + -- Debug switch -gnatd9 enables Lock Free implementation + + if not Debug_Flag_9 then + return False; + end if; + + -- Look for any entries declared in the visible part of the protected + -- declaration. + + N_Decl := First (Vis_Decls); + while Present (N_Decl) loop + if Nkind (N_Decl) = N_Entry_Declaration then + return False; + end if; + + N_Decl := Next (N_Decl); + end loop; + + -- Look for any entry, plus look for any scalar component declared in + -- the private part of the protected declaration. + + N_Decl := First (Pri_Decls); + while Present (N_Decl) loop + + -- Check at least one scalar component is declared + + if Nkind (N_Decl) = N_Component_Declaration then + if No_Component then + No_Component := False; + end if; + + Comp_Id := Defining_Identifier (N_Decl); + Comp_Type := Etype (Comp_Id); + + -- Verify the component is a scalar + + if not Is_Scalar_Type (Comp_Type) then + return False; + end if; + + Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type))); + + -- Check the size of the component is 8, 16, 32 or 64 bits + + case Comp_Size is + when 8 | 16 | 32 | 64 => + null; + when others => + return False; + end case; + + -- Check there is no entry declared in the private part. + + else + if Nkind (N_Decl) = N_Entry_Declaration then + return False; + end if; + end if; + + N_Decl := Next (N_Decl); + end loop; + + -- One scalar component must be present + + if No_Component then + return False; + end if; + + -- Ensure all protected subprograms meet the restrictions that allow the + -- lock free implementation. + + N_Decl := First (Decls); + while Present (N_Decl) loop + if Nkind (N_Decl) = N_Subprogram_Body + and then not Permit_Lock_Free (N_Decl) + then + return False; + end if; + + Next (N_Decl); + end loop; + + return True; + end Allow_Lock_Free_Implementation; + ----------------------- -- Build_Accept_Body -- ----------------------- @@ -2720,18 +3034,16 @@ package body Exp_Ch9 is if No (If_St) then If_St := Make_Implicit_If_Statement (Typ, - Condition => Cond, + Condition => Cond, Then_Statements => Stats, - Elsif_Parts => New_List); - + Elsif_Parts => New_List); Ret := If_St; else - Append ( + Append_To (Elsif_Parts (If_St), Make_Elsif_Part (Loc, Condition => Cond, - Then_Statements => Stats), - Elsif_Parts (If_St)); + Then_Statements => Stats)); end if; end Add_If_Clause; @@ -2788,7 +3100,7 @@ package body Exp_Ch9 is else -- Suppose entries e1, e2, ... have size l1, l2, ... we generate -- the following: - -- + -- if E <= l1 then return 1; -- elsif E <= l1 + l2 then return 2; -- ... @@ -2834,8 +3146,8 @@ package body Exp_Ch9 is return Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => Spec, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Ret))); @@ -2856,21 +3168,543 @@ package body Exp_Ch9 is begin return Make_Function_Specification (Loc, - Defining_Unit_Name => Id, + Defining_Unit_Name => Id, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Parm1, - Parameter_Type => + Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Parm2, - Parameter_Type => + Parameter_Type => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), - Result_Definition => New_Occurrence_Of ( + + Result_Definition => New_Occurrence_Of ( RTE (RE_Protected_Entry_Index), Loc)); end Build_Find_Body_Index_Spec; + ----------------------------------------------- + -- Build_Lock_Free_Protected_Subprogram_Body -- + ----------------------------------------------- + + function Build_Lock_Free_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Op_Spec : Node_Id; + P_Op_Spec : Node_Id; + Uactuals : List_Id; + Pformal : Node_Id; + Unprot_Call : Node_Id; + R : Node_Id; + Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning + Exc_Safe : Boolean; + + begin + Op_Spec := Specification (N); + Exc_Safe := Is_Exception_Safe (N); + + P_Op_Spec := + Build_Protected_Sub_Specification (N, Pid, Protected_Mode); + + -- Build a list of the formal parameters of the protected version of + -- the subprogram to use as the actual parameters of the unprotected + -- version. + + Uactuals := New_List; + Pformal := First (Parameter_Specifications (P_Op_Spec)); + while Present (Pformal) loop + Append_To (Uactuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); + Next (Pformal); + end loop; + + -- Make a call to the unprotected version of the subprogram built above + -- for use by the protected version built below. + + if Nkind (Op_Spec) = N_Function_Specification then + if Exc_Safe then + R := Make_Temporary (Loc, 'R'); + Unprot_Call := + Make_Object_Declaration (Loc, + Defining_Identifier => R, + Constant_Present => True, + Object_Definition => New_Copy (Result_Definition (N_Op_Spec)), + Expression => + Make_Function_Call (Loc, + Name => Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (R, Loc)); + + else + Unprot_Call := Make_Simple_Return_Statement (Loc, + Expression => Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + end if; + + else + Unprot_Call := + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals); + end if; + + if Nkind (Op_Spec) = N_Function_Specification + and then Exc_Safe + then + Unprot_Call := + Make_Block_Statement (Loc, + Declarations => New_List (Unprot_Call), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Return_Stmt))); + end if; + + return + Make_Subprogram_Body (Loc, + Declarations => Empty_List, + Specification => P_Op_Spec, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Unprot_Call))); + end Build_Lock_Free_Protected_Subprogram_Body; + + ------------------------------------------------- + -- Build_Lock_Free_Unprotected_Subprogram_Body -- + ------------------------------------------------- + + function Build_Lock_Free_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) return Node_Id + is + Decls : constant List_Id := Declarations (N); + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (N)) = E_Procedure; + Loc : constant Source_Ptr := Sloc (N); + + function Ren_Comp_Id (Decls : List_Id) return Entity_Id; + -- Given the list of delaration Decls, return the renamed entity + -- of the protected component accessed by the subprogram body. + + ----------------- + -- Ren_Comp_Id -- + ----------------- + + function Ren_Comp_Id (Decls : List_Id) return Entity_Id is + N_Decl : Node_Id; + Pri_Link : Node_Id; + + begin + N_Decl := First (Decls); + while Present (N_Decl) loop + + -- Look for a renaming declaration + + if Nkind (N_Decl) = N_Object_Renaming_Declaration then + Pri_Link := Prival_Link (Defining_Identifier (N_Decl)); + + -- Compare the renamed entity and the accessed component entity + -- in the LF_Sub_Table. + + if Present (Pri_Link) and then Pri_Link = Comp_Of (N) then + return Defining_Identifier (N_Decl); + end if; + end if; + + Next (N_Decl); + end loop; + + return Empty; + end Ren_Comp_Id; + + Obj_Id : constant Entity_Id := Ren_Comp_Id (Decls); + At_Comp_Id : Entity_Id; + At_Load_Id : Entity_Id; + Copy_Id : Entity_Id; + Exit_Stmt : Node_Id; + Label : Node_Id := Empty; + Label_Id : Entity_Id; + New_Body : Node_Id; + New_Decls : List_Id; + New_Stmts : List_Id; + Obj_Typ : Entity_Id; + Old_Id : Entity_Id; + Typ_Size : Int; + Unsigned_Id : Entity_Id; + + function Make_If (Stmt : Node_Id) return Node_Id; + -- Given the statement Stmt, return an if statement with Stmt at the end + -- of the list of statements. + + procedure Process_Stmts (Stmts : List_Id); + -- Wrap each return and raise statements in Stmts into an if statement + -- generated by Make_If. Replace all references to the protected object + -- Obj by a reference to its copy Obj_Copy. + + ------------- + -- Make_If -- + ------------- + + function Make_If (Stmt : Node_Id) return Node_Id is + begin + -- Generate (for Typ_Size = 32): + + -- if System.Atomic_Primitives.Atomic_Compare_Exchange_32 + -- (Obj'Address, + -- Interfaces.Unsigned_32! (Obj_Old), + -- Interfaces.Unsigned_32! (Obj_Copy)); + -- then + -- < Stmt > + -- else + -- goto L0; + -- end if; + + -- Check whether a label has already been created + + if not Present (Label) then + + -- Create a label which will point just after the last + -- statement of the loop statement generated in step 3. + + -- Generate: + + -- L0 : Label; + + Label_Id := + Make_Identifier (Loc, New_External_Name ('L', 0)); + + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + Label := Make_Label (Loc, Label_Id); + + Append_To (Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Label_Id), + Label_Construct => Label)); + end if; + + return + Make_If_Statement (Loc, + Condition => + Make_Function_Call (Loc, + Name => New_Reference_To (At_Comp_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Old_Id, Loc)), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Copy_Id, Loc)))), + + Then_Statements => New_List ( + Relocate_Node (Stmt)), + + Else_Statements => New_List ( + Make_Goto_Statement (Loc, + Name => New_Reference_To (Entity (Label_Id), Loc)))); + end Make_If; + + ------------------- + -- Process_Stmts -- + ------------------- + + procedure Process_Stmts (Stmts : List_Id) is + Stmt : Node_Id; + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Recognize a return and raise statement and wrap it into an if + -- statement. Replace all references to the protected object by + -- a reference to its copy. Reset all Analyzed flags in order to + -- reanalyze statments inside the new unprotected subprogram body. + + procedure Process_Nodes is + new Traverse_Proc (Check_Node); + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + begin + -- In case of a procedure, wrap each return and raise statements + -- inside an if statement created by Make_If. + + if Is_Procedure + and then Nkind_In (N, N_Simple_Return_Statement, + N_Extended_Return_Statement, + N_Raise_Statement) + and then + (Nkind (N) /= N_Simple_Return_Statement + or else N /= Last (Stmts)) + then + Rewrite (N, Make_If (N)); + return Skip; + + -- Replace all references to the protected object by a reference + -- to the new copy. + + elsif Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Entity (N) = Obj_Id + then + Rewrite (N, Make_Identifier (Loc, Chars (Copy_Id))); + return Skip; + end if; + + -- We mark the node as unanalyzed in order to reanalyze it inside + -- the unprotected subprogram body. + + Set_Analyzed (N, False); + + return OK; + end Check_Node; + + -- Start of processing for Process_Stmts + + begin + -- Process_Nodes for each statement in Stmts + + Stmt := First (Stmts); + while Present (Stmt) loop + Process_Nodes (Stmt); + Next (Stmt); + end loop; + end Process_Stmts; + + -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body + + begin + New_Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N))); + + -- Do the transformation only if the subprogram accesses a protected + -- component. + + if not Present (Obj_Id) then + goto Continue; + end if; + + Copy_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Obj_Id), Suffix => "_copy")); + + Obj_Typ := Etype (Obj_Id); + Typ_Size := UI_To_Int (Esize (Base_Type (Obj_Typ))); + + Process_Stmts (New_Stmts); + + -- Procedure case + + if Is_Procedure then + case Typ_Size is + when 8 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_8); + At_Load_Id := RTE (RE_Atomic_Load_8); + Unsigned_Id := RTE (RE_Uint8); + + when 16 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_16); + At_Load_Id := RTE (RE_Atomic_Load_16); + Unsigned_Id := RTE (RE_Uint16); + + when 32 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_32); + At_Load_Id := RTE (RE_Atomic_Load_32); + Unsigned_Id := RTE (RE_Uint32); + + when 64 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_64); + At_Load_Id := RTE (RE_Atomic_Load_64); + Unsigned_Id := RTE (RE_Uint64); + when others => null; + end case; + + -- Generate (e.g. for Typ_Size = 32): + + -- begin + -- loop + -- declare + -- Obj_Old : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); + -- Obj_Copy : Obj_Typ := Obj_Old; + -- begin + -- < New_Stmts > + -- exit when + -- System.Atomic_Primitives.Atomic_Compare_Exchange_32 + -- (Obj'Address, + -- Interfaces.Unsigned_32! (Obj_Old), + -- Interfaces.Unsigned_32! (Obj_Copy)); + -- end; + -- end loop; + -- end; + + -- Step 1: Define a copy and save the old value of the protected + -- object. The copy replaces all the references to the object present + -- in the body of the procedure. + + -- Generate: + + -- Obj_Old : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); + -- Obj_Copy : Obj_Typ := Obj_Old; + + Old_Id := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Obj_Id), Suffix => "_old")); + + New_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Old_Id, + Constant_Present => True, + Object_Definition => New_Reference_To (Obj_Typ, Loc), + Expression => Unchecked_Convert_To (Obj_Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (At_Load_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address))))), + Make_Object_Declaration (Loc, + Defining_Identifier => Copy_Id, + Object_Definition => New_Reference_To (Obj_Typ, Loc), + Expression => New_Reference_To (Old_Id, Loc))); + + -- Step 2: Create an exit statement of the loop statement generated + -- in step 3. + + -- Generate (for Typ_Size = 32): + + -- exit when System.Atomic_Primitives.Atomic_Compare_Exchange_32 + -- (Obj'Address, + -- Interfaces.Unsigned_32! (Obj_Old), + -- Interfaces.Unsigned_32! (Obj_Copy)); + + Exit_Stmt := + Make_Exit_Statement (Loc, + Condition => + Make_Function_Call (Loc, + Name => New_Reference_To (At_Comp_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Old_Id, Loc)), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Copy_Id, Loc))))); + + -- Check the last statement is a return statement + + if Nkind (Last (New_Stmts)) = N_Simple_Return_Statement then + Rewrite (Last (New_Stmts), Exit_Stmt); + else + Append_To (New_Stmts, Exit_Stmt); + end if; + + -- Step 3: Create the loop statement which encloses a block + -- declaration that contains all the statements of the original + -- procedure body. + + -- Generate: + + -- loop + -- declare + -- < New_Decls > + -- begin + -- < New_Stmts > + -- end; + -- end loop; + + New_Stmts := New_List ( + Make_Loop_Statement (Loc, + Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => New_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_Stmts))), + End_Label => Empty)); + + -- Append the label to the statements of the loop when needed + + if Present (Label) then + Append_To (Statements (First (New_Stmts)), Label); + end if; + + -- Function case + + else + case Typ_Size is + when 8 => + At_Load_Id := RTE (RE_Atomic_Load_8); + when 16 => + At_Load_Id := RTE (RE_Atomic_Load_16); + when 32 => + At_Load_Id := RTE (RE_Atomic_Load_32); + when 64 => + At_Load_Id := RTE (RE_Atomic_Load_64); + when others => null; + end case; + + -- Define a copy of the protected object which replaces all the + -- references to the object present in the body of the function. + + -- Generate: + + -- Obj_Copy : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Copy_Id, + Constant_Present => True, + Object_Definition => New_Reference_To (Obj_Typ, Loc), + Expression => Unchecked_Convert_To (Obj_Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (At_Load_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address)))))); + end if; + + << Continue >> + + -- Add renamings for the Protection object, discriminals, privals and + -- the entry index constant for use by debugger. + + Debug_Private_Data_Declarations (Decls); + + -- Make an unprotected version of the subprogram for use within the same + -- object, with new name and extra parameter representing the object. + + New_Body := + Make_Subprogram_Body (Loc, + Specification => + Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_Stmts)); + return New_Body; + end Build_Lock_Free_Unprotected_Subprogram_Body; + ------------------------- -- Build_Master_Entity -- ------------------------- @@ -3442,102 +4276,6 @@ package body Exp_Ch9 is Exc_Safe : Boolean; Lock_Kind : RE_Id; - function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; - -- Tell whether a given subprogram cannot raise an exception - - ----------------------- - -- Is_Exception_Safe -- - ----------------------- - - function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is - - function Has_Side_Effect (N : Node_Id) return Boolean; - -- Return True whenever encountering a subprogram call or raise - -- statement of any kind in the sequence of statements - - --------------------- - -- Has_Side_Effect -- - --------------------- - - -- What is this doing buried two levels down in exp_ch9. It seems - -- like a generally useful function, and indeed there may be code - -- duplication going on here ??? - - function Has_Side_Effect (N : Node_Id) return Boolean is - Stmt : Node_Id; - Expr : Node_Id; - - function Is_Call_Or_Raise (N : Node_Id) return Boolean; - -- Indicate whether N is a subprogram call or a raise statement - - ---------------------- - -- Is_Call_Or_Raise -- - ---------------------- - - function Is_Call_Or_Raise (N : Node_Id) return Boolean is - begin - return Nkind_In (N, N_Procedure_Call_Statement, - N_Function_Call, - N_Raise_Statement, - N_Raise_Constraint_Error, - N_Raise_Program_Error, - N_Raise_Storage_Error); - end Is_Call_Or_Raise; - - -- Start of processing for Has_Side_Effect - - begin - Stmt := N; - while Present (Stmt) loop - if Is_Call_Or_Raise (Stmt) then - return True; - end if; - - -- An object declaration can also contain a function call - -- or a raise statement - - if Nkind (Stmt) = N_Object_Declaration then - Expr := Expression (Stmt); - - if Present (Expr) and then Is_Call_Or_Raise (Expr) then - return True; - end if; - end if; - - Next (Stmt); - end loop; - - return False; - end Has_Side_Effect; - - -- Start of processing for Is_Exception_Safe - - begin - -- If the checks handled by the back end are not disabled, we cannot - -- ensure that no exception will be raised. - - if not Access_Checks_Suppressed (Empty) - or else not Discriminant_Checks_Suppressed (Empty) - or else not Range_Checks_Suppressed (Empty) - or else not Index_Checks_Suppressed (Empty) - or else Opt.Stack_Checking_Enabled - then - return False; - end if; - - if Has_Side_Effect (First (Declarations (Subprogram))) - or else - Has_Side_Effect ( - First (Statements (Handled_Statement_Sequence (Subprogram)))) - then - return False; - else - return True; - end if; - end Is_Exception_Safe; - - -- Start of processing for Build_Protected_Subprogram_Body - begin Op_Spec := Specification (N); Exc_Safe := Is_Exception_Safe (N); @@ -4698,6 +5436,21 @@ package body Exp_Ch9 is end loop; end Collect_Entry_Families; + ------------- + -- Comp_Of -- + ------------- + + function Comp_Of (Sub_Body : Node_Id) return Entity_Id is + begin + for Sub_Id in 1 .. LF_Sub_Table.Last loop + if Sub_Body = LF_Sub_Table.Table (Sub_Id).Sub_Body then + return LF_Sub_Table.Table (Sub_Id).Comp_Id; + end if; + end loop; + + return Empty; + end Comp_Of; + ----------------------- -- Concurrent_Object -- ----------------------- @@ -7715,6 +8468,9 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Pid : constant Entity_Id := Corresponding_Spec (N); + Lock_Free_On : constant Boolean := Allow_Lock_Free_Implementation (N); + -- This flag indicates whether the lock free implementation is active + Current_Node : Node_Id; Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; @@ -7843,8 +8599,14 @@ package body Exp_Ch9 is if not Is_Eliminated (Defining_Entity (Op_Body)) and then not Is_Eliminated (Corresponding_Spec (Op_Body)) then - New_Op_Body := - Build_Unprotected_Subprogram_Body (Op_Body, Pid); + if Lock_Free_On then + New_Op_Body := + Build_Lock_Free_Unprotected_Subprogram_Body + (Op_Body, Pid); + else + New_Op_Body := + Build_Unprotected_Subprogram_Body (Op_Body, Pid); + end if; Insert_After (Current_Node, New_Op_Body); Current_Node := New_Op_Body; @@ -7854,6 +8616,7 @@ package body Exp_Ch9 is -- appear that this is needed only if this is a visible -- operation of the type, or if it is an interrupt handler, -- and this was the strategy used previously in GNAT. + -- However, the operation may be exported through a 'Access -- to an external caller. This is the common idiom in code -- that uses the Ada 2005 Timing_Events package. As a result @@ -7863,9 +8626,15 @@ package body Exp_Ch9 is -- declaration in the protected body itself. if Present (Corresponding_Spec (Op_Body)) then - New_Op_Body := - Build_Protected_Subprogram_Body ( - Op_Body, Pid, Specification (New_Op_Body)); + if Lock_Free_On then + New_Op_Body := + Build_Lock_Free_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + else + New_Op_Body := + Build_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + end if; Insert_After (Current_Node, New_Op_Body); Analyze (New_Op_Body); @@ -12688,6 +13457,97 @@ package body Exp_Ch9 is end if; end Install_Private_Data_Declarations; + ----------------------- + -- Is_Exception_Safe -- + ----------------------- + + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is + + function Has_Side_Effect (N : Node_Id) return Boolean; + -- Return True whenever encountering a subprogram call or raise + -- statement of any kind in the sequence of statements + + --------------------- + -- Has_Side_Effect -- + --------------------- + + -- What is this doing buried two levels down in exp_ch9. It seems like a + -- generally useful function, and indeed there may be code duplication + -- going on here ??? + + function Has_Side_Effect (N : Node_Id) return Boolean is + Stmt : Node_Id; + Expr : Node_Id; + + function Is_Call_Or_Raise (N : Node_Id) return Boolean; + -- Indicate whether N is a subprogram call or a raise statement + + ---------------------- + -- Is_Call_Or_Raise -- + ---------------------- + + function Is_Call_Or_Raise (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Procedure_Call_Statement, + N_Function_Call, + N_Raise_Statement, + N_Raise_Constraint_Error, + N_Raise_Program_Error, + N_Raise_Storage_Error); + end Is_Call_Or_Raise; + + -- Start of processing for Has_Side_Effect + + begin + Stmt := N; + while Present (Stmt) loop + if Is_Call_Or_Raise (Stmt) then + return True; + end if; + + -- An object declaration can also contain a function call or a + -- raise statement. + + if Nkind (Stmt) = N_Object_Declaration then + Expr := Expression (Stmt); + + if Present (Expr) and then Is_Call_Or_Raise (Expr) then + return True; + end if; + end if; + + Next (Stmt); + end loop; + + return False; + end Has_Side_Effect; + + -- Start of processing for Is_Exception_Safe + + begin + -- If the checks handled by the back end are not disabled, we cannot + -- ensure that no exception will be raised. + + if not Access_Checks_Suppressed (Empty) + or else not Discriminant_Checks_Suppressed (Empty) + or else not Range_Checks_Suppressed (Empty) + or else not Index_Checks_Suppressed (Empty) + or else Opt.Stack_Checking_Enabled + then + return False; + end if; + + if Has_Side_Effect (First (Declarations (Subprogram))) + or else + Has_Side_Effect + (First (Statements (Handled_Statement_Sequence (Subprogram)))) + then + return False; + else + return True; + end if; + end Is_Exception_Safe; + --------------------------------- -- Is_Potentially_Large_Family -- --------------------------------- @@ -12702,11 +13562,12 @@ package body Exp_Ch9 is return Scope (Base_Index) = Standard_Standard and then Base_Index = Base_Type (Standard_Integer) and then Has_Discriminants (Conctyp) - and then Present - (Discriminant_Default_Value (First_Discriminant (Conctyp))) + and then + Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) and then (Denotes_Discriminant (Lo, True) - or else Denotes_Discriminant (Hi, True)); + or else + Denotes_Discriminant (Hi, True)); end Is_Potentially_Large_Family; ------------------------------------- diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 8a95ec5c876..756a3d19be3 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -509,7 +509,7 @@ package body Exp_Pakd is Shift : out Node_Id); -- This procedure performs common processing on the N_Indexed_Component -- parameter given as N, whose prefix is a reference to a packed array. - -- This is used for the get and set when the component size is 1,2,4 + -- This is used for the get and set when the component size is 1, 2, 4, -- or for other component sizes when the packed array type is a modular -- type (i.e. the cases that are handled with inline code). -- @@ -1472,10 +1472,10 @@ package body Exp_Pakd is end if; end if; - -- Now create copies removing side effects. Note that in some - -- complex cases, this may cause the fact that we have already - -- set a packed array type on Obj to get lost. So we save the - -- type of Obj, and make sure it is reset properly. + -- Now create copies removing side effects. Note that in some complex + -- cases, this may cause the fact that we have already set a packed + -- array type on Obj to get lost. So we save the type of Obj, and + -- make sure it is reset properly. declare T : constant Entity_Id := Etype (Obj); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ae7f2b95467..ae5470f659c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3940,27 +3940,29 @@ package body Exp_Util is return True; end Is_All_Null_Statements; - --------------------------------------------- - -- Is_Displacement_Of_Ctrl_Function_Result -- - --------------------------------------------- + -------------------------------------------------- + -- Is_Displacement_Of_Object_Or_Function_Result -- + -------------------------------------------------- - function Is_Displacement_Of_Ctrl_Function_Result + function Is_Displacement_Of_Object_Or_Function_Result (Obj_Id : Entity_Id) return Boolean is - function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean; - -- Determine whether object declaration N is initialized by a controlled - -- function call. + function Is_Controlled_Function_Call (N : Node_Id) return Boolean; + -- Determine if particular node denotes a controlled function call function Is_Displace_Call (N : Node_Id) return Boolean; -- Determine whether a particular node is a call to Ada.Tags.Displace. -- The call might be nested within other actions such as conversions. - ---------------------------------- - -- Initialized_By_Ctrl_Function -- - ---------------------------------- + function Is_Source_Object (N : Node_Id) return Boolean; + -- Determine whether a particular node denotes a source object + + --------------------------------- + -- Is_Controlled_Function_Call -- + --------------------------------- - function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is - Expr : Node_Id := Original_Node (Expression (N)); + function Is_Controlled_Function_Call (N : Node_Id) return Boolean is + Expr : Node_Id := Original_Node (N); begin if Nkind (Expr) = N_Function_Call then @@ -3977,7 +3979,7 @@ package body Exp_Util is Nkind_In (Expr, N_Expanded_Name, N_Identifier) and then Ekind (Entity (Expr)) = E_Function and then Needs_Finalization (Etype (Entity (Expr))); - end Initialized_By_Ctrl_Function; + end Is_Controlled_Function_Call; ---------------------- -- Is_Displace_Call -- @@ -4004,39 +4006,66 @@ package body Exp_Util is end loop; return - Nkind (Call) = N_Function_Call + Present (Call) + and then Nkind (Call) = N_Function_Call and then Is_RTE (Entity (Name (Call)), RE_Displace); end Is_Displace_Call; + ---------------------- + -- Is_Source_Object -- + ---------------------- + + function Is_Source_Object (N : Node_Id) return Boolean is + begin + return + Present (N) + and then Nkind (N) in N_Has_Entity + and then Is_Object (Entity (N)) + and then Comes_From_Source (N); + end Is_Source_Object; + -- Local variables Decl : constant Node_Id := Parent (Obj_Id); Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); Orig_Decl : constant Node_Id := Original_Node (Decl); - -- Start of processing for Is_Displacement_Of_Ctrl_Function_Result + -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result begin - -- Detect the following case: + -- Case 1: + + -- Obj : CW_Type := Function_Call (...); + + -- rewritten into: + + -- Tmp : ... := Function_Call (...)'reference; + -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp)); + + -- where the return type of the function and the class-wide type require + -- dispatch table pointer displacement. + + -- Case 2: - -- Obj : Class_Wide_Type := Function_Call (...); + -- Obj : CW_Type := Src_Obj; - -- which is rewritten into: + -- rewritten into: - -- Temp : ... := Function_Call (...)'reference; - -- Obj : Class_Wide_Type renames (... Ada.Tags.Displace (Temp)); + -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); - -- when the return type of the function and the class-wide type require + -- where the type of the source object and the class-wide type require -- dispatch table pointer displacement. return Nkind (Decl) = N_Object_Renaming_Declaration and then Nkind (Orig_Decl) = N_Object_Declaration and then Comes_From_Source (Orig_Decl) - and then Initialized_By_Ctrl_Function (Orig_Decl) and then Is_Class_Wide_Type (Obj_Typ) - and then Is_Displace_Call (Renamed_Object (Obj_Id)); - end Is_Displacement_Of_Ctrl_Function_Result; + and then Is_Displace_Call (Renamed_Object (Obj_Id)) + and then + (Is_Controlled_Function_Call (Expression (Orig_Decl)) + or else Is_Source_Object (Expression (Orig_Decl))); + end Is_Displacement_Of_Object_Or_Function_Result; ------------------------------ -- Is_Finalizable_Transient -- @@ -4475,74 +4504,6 @@ package body Exp_Util is and then Is_Library_Level_Entity (Typ); end Is_Library_Level_Tagged_Type; - ---------------------------------- - -- Is_Null_Access_BIP_Func_Call -- - ---------------------------------- - - function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is - Call : Node_Id := Expr; - - begin - -- Build-in-place calls usually appear in 'reference format - - if Nkind (Call) = N_Reference then - Call := Prefix (Call); - end if; - - if Nkind_In (Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - end if; - - if Is_Build_In_Place_Function_Call (Call) then - declare - Access_Nam : Name_Id := No_Name; - Actual : Node_Id; - Param : Node_Id; - Formal : Node_Id; - - begin - -- Examine all parameter associations of the function call - - Param := First (Parameter_Associations (Call)); - while Present (Param) loop - if Nkind (Param) = N_Parameter_Association - and then Nkind (Selector_Name (Param)) = N_Identifier - then - Formal := Selector_Name (Param); - Actual := Explicit_Actual_Parameter (Param); - - -- Construct the name of formal BIPaccess. It is much easier - -- to extract the name of the function using an arbitrary - -- formal's scope rather than the Name field of Call. - - if Access_Nam = No_Name - and then Present (Entity (Formal)) - then - Access_Nam := - New_External_Name - (Chars (Scope (Entity (Formal))), - BIP_Formal_Suffix (BIP_Object_Access)); - end if; - - -- A match for BIPaccess => null has been found - - if Chars (Formal) = Access_Nam - and then Nkind (Actual) = N_Null - then - return True; - end if; - end if; - - Next (Param); - end loop; - end; - end if; - - return False; - end Is_Null_Access_BIP_Func_Call; - -------------------------- -- Is_Non_BIP_Func_Call -- -------------------------- @@ -4949,6 +4910,77 @@ package body Exp_Util is end if; end Is_Renamed_Object; + -------------------------------------- + -- Is_Secondary_Stack_BIP_Func_Call -- + -------------------------------------- + + function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is + Call : Node_Id := Expr; + + begin + -- Build-in-place calls usually appear in 'reference format. Note that + -- the accessibility check machinery may add an extra 'reference due to + -- side effect removal. + + while Nkind (Call) = N_Reference loop + Call := Prefix (Call); + end loop; + + if Nkind_In (Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Call := Expression (Call); + end if; + + if Is_Build_In_Place_Function_Call (Call) then + declare + Access_Nam : Name_Id := No_Name; + Actual : Node_Id; + Param : Node_Id; + Formal : Node_Id; + + begin + -- Examine all parameter associations of the function call + + Param := First (Parameter_Associations (Call)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association + and then Nkind (Selector_Name (Param)) = N_Identifier + then + Formal := Selector_Name (Param); + Actual := Explicit_Actual_Parameter (Param); + + -- Construct the name of formal BIPalloc. It is much easier + -- to extract the name of the function using an arbitrary + -- formal's scope rather than the Name field of Call. + + if Access_Nam = No_Name + and then Present (Entity (Formal)) + then + Access_Nam := + New_External_Name + (Chars (Scope (Entity (Formal))), + BIP_Formal_Suffix (BIP_Alloc_Form)); + end if; + + -- A match for BIPalloc => 2 has been found + + if Chars (Formal) = Access_Nam + and then Nkind (Actual) = N_Integer_Literal + and then Intval (Actual) = Uint_2 + then + return True; + end if; + end if; + + Next (Param); + end loop; + end; + end if; + + return False; + end Is_Secondary_Stack_BIP_Func_Call; + ------------------------------------- -- Is_Tag_To_Class_Wide_Conversion -- ------------------------------------- @@ -7123,18 +7155,17 @@ package body Exp_Util is -- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- -- Obj : Access_Typ := - -- BIP_Function_Call - -- (..., BIPaccess => null, ...)'reference; + -- BIP_Function_Call (BIPalloc => 2, ...)'reference; elsif Is_Access_Type (Obj_Typ) and then Needs_Finalization (Available_View (Designated_Type (Obj_Typ))) and then Present (Expr) and then - (Is_Null_Access_BIP_Func_Call (Expr) - or else - (Is_Non_BIP_Func_Call (Expr) - and then not Is_Related_To_Func_Return (Obj_Id))) + (Is_Secondary_Stack_BIP_Func_Call (Expr) + or else + (Is_Non_BIP_Func_Call (Expr) + and then not Is_Related_To_Func_Return (Obj_Id))) then return True; @@ -7187,17 +7218,18 @@ package body Exp_Util is then return True; - -- Detect a case where a source object has been initialized by a - -- controlled function call which was later rewritten as a class- - -- wide conversion of Ada.Tags.Displace. + -- Detect a case where a source object has been initialized by + -- a controlled function call or another object which was later + -- rewritten as a class-wide conversion of Ada.Tags.Displace. - -- Obj : Class_Wide_Type := Function_Call (...); + -- Obj1 : CW_Type := Src_Obj; + -- Obj2 : CW_Type := Function_Call (...); - -- Temp : ... := Function_Call (...)'reference; - -- Obj : Class_Wide_Type renames - -- (... Ada.Tags.Displace (Temp)); + -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); + -- Tmp : ... := Function_Call (...)'reference; + -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); - elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then + elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then return True; end if; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 97e9b5c9a56..9f3ae2a2554 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -521,11 +521,12 @@ package Exp_Util is -- False otherwise. True for an empty list. It is an error to call this -- routine with No_List as the argument. - function Is_Displacement_Of_Ctrl_Function_Result + function Is_Displacement_Of_Object_Or_Function_Result (Obj_Id : Entity_Id) return Boolean; - -- Determine whether Obj_Id is a source object that has been initialized by - -- a controlled function call later rewritten as a class-wide conversion of - -- Ada.Tags.Displace. + -- Determine whether Obj_Id is a source entity that has been initialized by + -- either a controlled function call or the assignment of another source + -- object. In both cases the initialization expression is rewritten as a + -- class-wide conversion of Ada.Tags.Displace. function Is_Finalizable_Transient (Decl : Node_Id; @@ -548,13 +549,20 @@ package Exp_Util is -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. - function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean; - -- Determine whether node Expr denotes a build-in-place function call with - -- a value of "null" for extra formal BIPaccess. - function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; -- Determine whether node Expr denotes a non build-in-place function call + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; + -- Node N is an object reference. This function returns True if it is + -- possible that the object may not be aligned according to the normal + -- default alignment requirement for its type (e.g. if it appears in a + -- packed record, or as part of a component that has a component clause.) + + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; + -- Determine whether the node P is a slice of an array where the slice + -- result may cause alignment problems because it has an alignment that + -- is not compatible with the type. Return True if so. + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed array, i.e. -- whether the designated object is a component of a bit packed array, or a @@ -571,17 +579,6 @@ package Exp_Util is -- Determine whether object Id is related to an expanded return statement. -- The case concerned is "return Id.all;". - function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; - -- Determine whether the node P is a slice of an array where the slice - -- result may cause alignment problems because it has an alignment that - -- is not compatible with the type. Return True if so. - - function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; - -- Node N is an object reference. This function returns True if it is - -- possible that the object may not be aligned according to the normal - -- default alignment requirement for its type (e.g. if it appears in a - -- packed record, or as part of a component that has a component clause.) - function Is_Renamed_Object (N : Node_Id) return Boolean; -- Returns True if the node N is a renamed object. An expression is -- considered to be a renamed object if either it is the Name of an object @@ -593,6 +590,10 @@ package Exp_Util is -- We consider that a (1 .. 2) is a renamed object since it is the prefix -- of the name in the renaming declaration. + function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean; + -- Determine whether Expr denotes a build-in-place function which returns + -- its result on the secondary stack. + function Is_Tag_To_Class_Wide_Conversion (Obj_Id : Entity_Id) return Boolean; -- Determine whether object Obj_Id is the result of a tag-to-class-wide diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index fc7600070f7..3eae40e036b 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2161,8 +2161,16 @@ package body Freeze is -- Here is where we do the processing for reversed bit order - else + elsif not Reverse_Storage_Order (Rec) then Adjust_Record_For_Reverse_Bit_Order (Rec); + + -- Case where we have both a reverse Bit_Order and a corresponding + -- Scalar_Storage_Order: leave record untouched, the back-end + -- will take care of required layout conversions. + + else + null; + end if; end if; diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index c6e18efa5b7..94f69642af4 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2012, 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- -- @@ -33,7 +33,7 @@ with System; use System; with System.OS_Constants; use System.OS_Constants; with Ada.Calendar; use Ada.Calendar; -with GNAT.IO; +with GNAT.IO; use GNAT.IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regpat; use GNAT.Regpat; @@ -678,6 +678,7 @@ package body GNAT.Expect is -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 + Close (Descriptors (D).Input_Fd); Descriptors (D).Input_Fd := Invalid_FD; Result := Expect_Process_Died; return; @@ -893,7 +894,8 @@ package body GNAT.Expect is begin Non_Blocking_Spawn - (Process, Command, Arguments, Err_To_Out => Err_To_Out); + (Process, Command, Arguments, Err_To_Out => Err_To_Out, + Buffer_Size => 0); if Input'Length > 0 then Send (Process, Input); @@ -1055,17 +1057,18 @@ package body GNAT.Expect is Command_With_Path : String_Access; begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - Command_With_Path := Locate_Exec_On_Path (Command); if Command_With_Path = null then raise Invalid_Process; end if; + -- Create the rest of the pipes once we know we will be able to + -- execute the process. + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + -- Fork a new process Descriptor.Pid := Fork; @@ -1365,6 +1368,8 @@ package body GNAT.Expect is end if; if Create_Pipe (Pipe2) /= 0 then + Close (Pipe1.Input); + Close (Pipe1.Output); return; end if; @@ -1389,7 +1394,7 @@ package body GNAT.Expect is -- Create a separate pipe for standard error if Create_Pipe (Pipe3) /= 0 then - return; + Pipe3.all := Pipe2.all; end if; end if; diff --git a/gcc/ada/g-sse.ads b/gcc/ada/g-sse.ads index 706516b9830..60d3577ad41 100644 --- a/gcc/ada/g-sse.ads +++ b/gcc/ada/g-sse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,6 +40,8 @@ -- GNU/Linux x86 and x86_64 -- Windows XP/Vista x86 and x86_64 +-- Solaris x86 +-- Darwin x86_64 -- This unit exposes vector _component_ types together with general comments -- on the binding contents. diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 9991405e3cc..5c4acda5388 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1083,6 +1083,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),) TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB = -lposix4 -lthread MISCLIB = -lposix4 -lnsl -lsocket @@ -1175,6 +1177,8 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),) mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ indepsw.adb<indepsw-gnu.adb + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual @@ -1231,6 +1235,8 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb GNATLIB_SHARED = gnatlib-shared-dual + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB= -lpthread GMEM_LIB = gmemlib @@ -1259,6 +1265,8 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),) mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb GNATLIB_SHARED = gnatlib-shared-dual + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB= -lpthread GMEM_LIB = gmemlib @@ -2160,6 +2168,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) $(X86_TARGET_PAIRS) \ system.ads<system-darwin-x86.ads endif + + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o endif ifeq ($(strip $(filter-out %x86_64,$(arch))),) @@ -2178,6 +2188,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) $(X86_64_TARGET_PAIRS) \ system.ads<system-darwin-x86_64.ads endif + + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o endif ifeq ($(strip $(filter-out powerpc%,$(arch))),) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index b925f422a21..dac9942237f 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -81,9 +81,6 @@ #define FOREIGN_FORCE_REALIGN_STACK 0 #endif -/* The (internal) name of the System.Secondary_Stack.SS_Mark function. */ -#define SS_MARK_NAME "system__secondary_stack__ss_mark" - struct incomplete { struct incomplete *next; @@ -4409,21 +4406,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) get_identifier ("force_align_arg_pointer"), NULL_TREE, gnat_entity); - /* ??? Declare System.Secondary_Stack.SS_Mark as leaf, in order to - avoid creating abnormal edges in SJLJ mode, which can break the - dominance relationship if there is a dynamic stack allocation. - We cannot do this in System.Secondary_Stack directly since it's - a compiler unit and this would introduce bootstrap path issues. */ - if (IDENTIFIER_LENGTH (gnu_entity_name) == strlen (SS_MARK_NAME) - && IDENTIFIER_POINTER (gnu_entity_name)[0] == SS_MARK_NAME[0] - && IDENTIFIER_POINTER (gnu_entity_name)[1] == SS_MARK_NAME[1] - && IDENTIFIER_POINTER (gnu_entity_name)[2] == SS_MARK_NAME[2] - && gnu_entity_name == get_identifier (SS_MARK_NAME)) - prepend_one_attribute_to - (&attr_list, ATTR_MACHINE_ATTRIBUTE, - get_identifier ("leaf"), NULL_TREE, - gnat_entity); - /* The lists have been built in reverse. */ gnu_param_list = nreverse (gnu_param_list); if (has_stub) diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 5c313ac76f0..e8e4d6e978c 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -94,10 +94,12 @@ Texts. A copy of the license is included in the section entitled @ifset unw @set PLATFORM +@set TITLESUFFIX @end ifset @ifset vms @set PLATFORM OpenVMS +@set TITLESUFFIX for OpenVMS @end ifset @c @ovar(ARG) @@ -115,7 +117,7 @@ Texts. A copy of the license is included in the section entitled @c of the @ovar macro have been expanded inline. -@settitle @value{EDITION} User's Guide @value{PLATFORM} +@settitle @value{EDITION} User's Guide @value{TITLESUFFIX} @dircategory GNU Ada tools @direntry * @value{EDITION} User's Guide: (gnat_ugn). @value{PLATFORM} @@ -484,6 +486,7 @@ Creating Unit Tests Using gnattest * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +* Support for other platforms/run-times:: * Current Limitations:: Other Utility Programs @@ -3077,7 +3080,7 @@ $ gnatlink ada_unit file1.o file2.o --LINK=./my_script Where CC is the name of the non-GNU C++ compiler. If the @code{zero cost} exception mechanism is used, and the platform -supports automatic registration of exception tables (e.g.@: Solaris or IRIX), +supports automatic registration of exception tables (e.g.@: Solaris), paths to more objects are required: @smallexample @@ -17988,6 +17991,7 @@ default location. * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +* Support for other platforms/run-times:: * Current Limitations:: @end menu @@ -18474,6 +18478,25 @@ gnatmake -Pmixing/test_driver.gpr mixing/test_runner @end smallexample +@node Support for other platforms/run-times +@section Support for other platforms/run-times + +@noindent +@command{gnattest} can be used to generate the test harness for platforms +and run-time libraries others than the default native target with the +default full run-time. For example, when using a limited run-time library +such as Zero FootPrint (ZFP), a simplified harness is generated. + +Two variables are used to tell the underlying AUnit framework how to generate +the test harness: @code{PLATFORM}, which identifies the target, and +@code{RUNTIME}, used to determine the run-time library for which the harness +is generated. For example, the following options are used to generate the +AUnit test harness for a PowerPC ELF target using the ZFP run-time library: + +@smallexample +gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp +@end smallexample + @node Current Limitations @section Current Limitations diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 2d67ea03ccd..e25355bfc30 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -196,6 +196,10 @@ package body Lib.Writ is Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean; -- Array of flags to show which units have Elaborate_All_Desirable set + type Yes_No is (Unknown, Yes, No); + + Implicit_With : array (Units.First .. Last_Unit) of Yes_No; + Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2)); -- Sorted table of source dependencies. One extra entry in case we -- have to add a dummy entry for System. @@ -276,6 +280,15 @@ package body Lib.Writ is else Set_From_With_Type (Cunit_Entity (Unum)); end if; + + if Implicit_With (Unum) /= Yes then + if Implicit_With_From_Instantiation (Item) then + Implicit_With (Unum) := Yes; + + else + Implicit_With (Unum) := No; + end if; + end if; end if; Next (Item); @@ -552,6 +565,7 @@ package body Lib.Writ is Elab_All_Flags (J) := False; Elab_Des_Flags (J) := False; Elab_All_Des_Flags (J) := False; + Implicit_With (J) := Unknown; end loop; Collect_Withs (Unode); @@ -770,10 +784,14 @@ package body Lib.Writ is Uname := Units.Table (Unum).Unit_Name; Fname := Units.Table (Unum).Unit_File_Name; - if Ekind (Cunit_Entity (Unum)) = E_Package + if Implicit_With (Unum) = Yes then + Write_Info_Initiate ('Z'); + + elsif Ekind (Cunit_Entity (Unum)) = E_Package and then From_With_Type (Cunit_Entity (Unum)) then Write_Info_Initiate ('Y'); + else Write_Info_Initiate ('W'); end if; diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 4961fedc8c1..c9ab1e03b10 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -40,102 +40,19 @@ package body Alfa is -- Table of Alfa_Entities, True for each entity kind used in Alfa Alfa_Entities : constant array (Entity_Kind) of Boolean := - (E_Void => False, - E_Variable => True, - E_Component => False, - E_Constant => True, - E_Discriminant => False, - - E_Loop_Parameter => True, - E_In_Parameter => True, - E_Out_Parameter => True, - E_In_Out_Parameter => True, - E_Generic_In_Out_Parameter => False, - - E_Generic_In_Parameter => False, - E_Named_Integer => False, - E_Named_Real => False, - E_Enumeration_Type => False, - E_Enumeration_Subtype => False, - - E_Signed_Integer_Type => False, - E_Signed_Integer_Subtype => False, - E_Modular_Integer_Type => False, - E_Modular_Integer_Subtype => False, - E_Ordinary_Fixed_Point_Type => False, - - E_Ordinary_Fixed_Point_Subtype => False, - E_Decimal_Fixed_Point_Type => False, - E_Decimal_Fixed_Point_Subtype => False, - E_Floating_Point_Type => False, - E_Floating_Point_Subtype => False, - - E_Access_Type => False, - E_Access_Subtype => False, - E_Access_Attribute_Type => False, - E_Allocator_Type => False, - E_General_Access_Type => False, - - E_Access_Subprogram_Type => False, - E_Access_Protected_Subprogram_Type => False, - E_Anonymous_Access_Subprogram_Type => False, - E_Anonymous_Access_Protected_Subprogram_Type => False, - E_Anonymous_Access_Type => False, - - E_Array_Type => False, - E_Array_Subtype => False, - E_String_Type => False, - E_String_Subtype => False, - E_String_Literal_Subtype => False, - - E_Class_Wide_Type => False, - E_Class_Wide_Subtype => False, - E_Record_Type => False, - E_Record_Subtype => False, - E_Record_Type_With_Private => False, - - E_Record_Subtype_With_Private => False, - E_Private_Type => False, - E_Private_Subtype => False, - E_Limited_Private_Type => False, - E_Limited_Private_Subtype => False, - - E_Incomplete_Type => False, - E_Incomplete_Subtype => False, - E_Task_Type => False, - E_Task_Subtype => False, - E_Protected_Type => False, - - E_Protected_Subtype => False, - E_Exception_Type => False, - E_Subprogram_Type => False, - E_Enumeration_Literal => False, - E_Function => True, - - E_Operator => True, - E_Procedure => True, - E_Entry => False, - E_Entry_Family => False, - E_Block => False, - - E_Entry_Index_Parameter => False, - E_Exception => False, - E_Generic_Function => False, - E_Generic_Package => False, - E_Generic_Procedure => False, - - E_Label => False, - E_Loop => False, - E_Return_Statement => False, - E_Package => False, - - E_Package_Body => False, - E_Protected_Object => False, - E_Protected_Body => False, - E_Task_Body => False, - E_Subprogram_Body => False); + (E_Constant => True, + E_Function => True, + E_In_Out_Parameter => True, + E_In_Parameter => True, + E_Loop_Parameter => True, + E_Operator => True, + E_Out_Parameter => True, + E_Procedure => True, + E_Variable => True, + others => False); -- True for each reference type used in Alfa + Alfa_References : constant array (Character) of Boolean := ('m' => True, 'r' => True, @@ -149,12 +66,15 @@ package body Alfa is -- Local Variables -- --------------------- + Heap : Entity_Id := Empty; + -- A special entity which denotes the heap object + package Drefs is new Table.Table ( Table_Component_Type => Xref_Entry, Table_Index_Type => Xref_Entry_Number, Table_Low_Bound => 1, - Table_Initial => Alloc.Xrefs_Initial, - Table_Increment => Alloc.Xrefs_Increment, + Table_Initial => Alloc.Drefs_Initial, + Table_Increment => Alloc.Drefs_Increment, Table_Name => "Drefs"); -- Table of cross-references for reads and writes through explicit -- dereferences, that are output as reads/writes to the special variable @@ -165,9 +85,12 @@ package body Alfa is -- Local Subprograms -- ----------------------- - procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat); - -- Add file U and all scopes in U to the tables Alfa_File_Table and - -- Alfa_Scope_Table. + procedure Add_Alfa_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat); + -- Add file and corresponding scopes for unit to the tables Alfa_File_Table + -- and Alfa_Scope_Table. When two units are present for the same + -- compilation unit, as it happens for library-level instantiations of + -- generics, then Ubody /= Uspec, and all scopes are added to the same + -- Alfa file. Otherwise Ubody = Uspec. procedure Add_Alfa_Scope (N : Node_Id); -- Add scope N to the table Alfa_Scope_Table @@ -202,16 +125,15 @@ package body Alfa is (N : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean); - -- Traverse the corresponding constructs, calling Process on all - -- declarations. + -- Traverse corresponding construct, calling Process on all declarations ------------------- -- Add_Alfa_File -- ------------------- - procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat) is + procedure Add_Alfa_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat) is + File : constant Source_File_Index := Source_Index (Uspec); From : Scope_Index; - S : constant Source_File_Index := Source_Index (U); File_Name : String_Ptr; Unit_File_Name : String_Ptr; @@ -220,69 +142,84 @@ package body Alfa is -- Source file could be inexistant as a result of an error, if option -- gnatQ is used. - if S = No_Source_File then + if File = No_Source_File then return; end if; From := Alfa_Scope_Table.Last + 1; - Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_Alfa_Scope'Access, - Inside_Stubs => False); + -- Unit might not have an associated compilation unit, as seen in code + -- filling Sdep_Table in Write_ALI. + + if Present (Cunit (Ubody)) then + Traverse_Compilation_Unit + (CU => Cunit (Ubody), + Process => Detect_And_Add_Alfa_Scope'Access, + Inside_Stubs => False); + end if; + + -- When two units are present for the same compilation unit, as it + -- happens for library-level instantiations of generics, then add all + -- scopes to the same Alfa file. + + if Ubody /= Uspec then + if Present (Cunit (Uspec)) then + Traverse_Compilation_Unit + (CU => Cunit (Uspec), + Process => Detect_And_Add_Alfa_Scope'Access, + Inside_Stubs => False); + end if; + end if; -- Update scope numbers declare - Count : Nat; - + Scope_Id : Int; begin - Count := 1; - for S in From .. Alfa_Scope_Table.Last loop + Scope_Id := 1; + for Index in From .. Alfa_Scope_Table.Last loop declare - E : Entity_Id renames Alfa_Scope_Table.Table (S).Scope_Entity; - + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); begin - if Lib.Get_Source_Unit (E) = U then - Alfa_Scope_Table.Table (S).Scope_Num := Count; - Alfa_Scope_Table.Table (S).File_Num := D; - Count := Count + 1; - - else - -- Mark for removal a scope S which is not located in unit - -- U, for example for scope inside generics that get - -- instantiated. - - Alfa_Scope_Table.Table (S).Scope_Num := 0; - end if; + S.Scope_Num := Scope_Id; + S.File_Num := Dspec; + Scope_Id := Scope_Id + 1; end; end loop; end; + -- Remove those scopes previously marked for removal + declare - Snew : Scope_Index; + Scope_Id : Scope_Index; begin - Snew := From; - for S in From .. Alfa_Scope_Table.Last loop - -- Remove those scopes previously marked for removal - - if Alfa_Scope_Table.Table (S).Scope_Num /= 0 then - Alfa_Scope_Table.Table (Snew) := Alfa_Scope_Table.Table (S); - Snew := Snew + 1; - end if; + Scope_Id := From; + for Index in From .. Alfa_Scope_Table.Last loop + declare + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + begin + if S.Scope_Num /= 0 then + Alfa_Scope_Table.Table (Scope_Id) := S; + Scope_Id := Scope_Id + 1; + end if; + end; end loop; - Alfa_Scope_Table.Set_Last (Snew - 1); + Alfa_Scope_Table.Set_Last (Scope_Id - 1); end; -- Make entry for new file in file table - Get_Name_String (Reference_Name (S)); + Get_Name_String (Reference_Name (File)); File_Name := new String'(Name_Buffer (1 .. Name_Len)); - -- For subunits, also retrieve the file name of the unit + -- For subunits, also retrieve the file name of the unit. Only do so if + -- unit has an associated compilation unit. - if Present (Cunit (Unit (S))) - and then Nkind (Unit (Cunit (Unit (S)))) = N_Subunit + if Present (Cunit (Uspec)) + and then Present (Cunit (Unit (File))) + and then Nkind (Unit (Cunit (Unit (File)))) = N_Subunit then Get_Name_String (Reference_Name (Main_Source_File)); Unit_File_Name := new String'(Name_Buffer (1 .. Name_Len)); @@ -291,7 +228,7 @@ package body Alfa is Alfa_File_Table.Append ( (File_Name => File_Name, Unit_File_Name => Unit_File_Name, - File_Num => D, + File_Num => Dspec, From_Scope => From, To_Scope => Alfa_Scope_Table.Last)); end Add_Alfa_File; @@ -376,55 +313,69 @@ package body Alfa is -------------------- procedure Add_Alfa_Xrefs is - Cur_Scope_Idx : Scope_Index; - From_Xref_Idx : Xref_Index; - Cur_Entity : Entity_Id; - Cur_Entity_Name : String_Ptr; - - package Scopes is - No_Scope : constant Nat := 0; - function Get_Scope_Num (N : Entity_Id) return Nat; - procedure Set_Scope_Num (N : Entity_Id; Num : Nat); - end Scopes; - - ------------ - -- Scopes -- - ------------ - - package body Scopes is - type Scope is record - Num : Nat; - Entity : Entity_Id; - end record; - - package Scopes is new GNAT.HTable.Simple_HTable - (Header_Num => Entity_Hashed_Range, - Element => Scope, - No_Element => (Num => No_Scope, Entity => Empty), - Key => Entity_Id, - Hash => Entity_Hash, - Equal => "="); - - ------------------- - -- Get_Scope_Num -- - ------------------- - - function Get_Scope_Num (N : Entity_Id) return Nat is - begin - return Scopes.Get (N).Num; - end Get_Scope_Num; + function Entity_Of_Scope (S : Scope_Index) return Entity_Id; + -- Return the entity which maps to the input scope index - ------------------- - -- Set_Scope_Num -- - ------------------- + function Get_Entity_Type (E : Entity_Id) return Character; + -- Return a character representing the type of entity - procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is - begin - Scopes.Set (K => N, E => Scope'(Num => Num, Entity => N)); - end Set_Scope_Num; - end Scopes; + function Is_Alfa_Reference + (E : Entity_Id; + Typ : Character) return Boolean; + -- Return whether entity reference E meets Alfa requirements. Typ is the + -- reference type. + + function Is_Alfa_Scope (E : Entity_Id) return Boolean; + -- Return whether the entity or reference scope meets requirements for + -- being an Alfa scope. + + function Is_Future_Scope_Entity + (E : Entity_Id; + S : Scope_Index) return Boolean; + -- Check whether entity E is in Alfa_Scope_Table at index S or higher + + function Is_Global_Constant (E : Entity_Id) return Boolean; + -- Return True if E is a global constant for which we should ignore + -- reads in Alfa. + + function Lt (Op1 : Natural; Op2 : Natural) return Boolean; + -- Comparison function for Sort call + + procedure Move (From : Natural; To : Natural); + -- Move procedure for Sort call + + procedure Update_Scope_Range + (S : Scope_Index; + From : Xref_Index; + To : Xref_Index); + -- Update the scope which maps to S with the new range From .. To + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + function Get_Scope_Num (N : Entity_Id) return Nat; + -- Return the scope number associated to entity N + + procedure Set_Scope_Num (N : Entity_Id; Num : Nat); + -- Associate entity N to scope number Num + + No_Scope : constant Nat := 0; + -- Initial scope counter - use Scopes; + type Scope_Rec is record + Num : Nat; + Entity : Entity_Id; + end record; + -- Type used to relate an entity and a scope number + + package Scopes is new GNAT.HTable.Simple_HTable + (Header_Num => Entity_Hashed_Range, + Element => Scope_Rec, + No_Element => (Num => No_Scope, Entity => Empty), + Key => Entity_Id, + Hash => Entity_Hash, + Equal => "="); + -- Package used to build a correspondance between entities and scope + -- numbers used in Alfa cross references. Nrefs : Nat := Xrefs.Last; -- Number of references in table. This value may get reset (reduced) @@ -432,6 +383,8 @@ package body Alfa is -- not suitable for local cross-references. Nrefs_Add : constant Nat := Drefs.Last; + -- Number of additional references which correspond to dereferences in + -- the source code. Rnums : array (0 .. Nrefs + Nrefs_Add) of Nat; -- This array contains numbers of references in the Xrefs table. This @@ -439,13 +392,149 @@ package body Alfa is -- for the call to sort. When we sort the table, we move the entries in -- Rnums around, but we do not move the original table entries. - function Lt (Op1, Op2 : Natural) return Boolean; - -- Comparison function for Sort call + --------------------- + -- Entity_Of_Scope -- + --------------------- - procedure Move (From : Natural; To : Natural); - -- Move procedure for Sort call + function Entity_Of_Scope (S : Scope_Index) return Entity_Id is + begin + return Alfa_Scope_Table.Table (S).Scope_Entity; + end Entity_Of_Scope; - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + --------------------- + -- Get_Entity_Type -- + --------------------- + + function Get_Entity_Type (E : Entity_Id) return Character is + begin + case Ekind (E) is + when E_Out_Parameter => return '<'; + when E_In_Out_Parameter => return '='; + when E_In_Parameter => return '>'; + when others => return '*'; + end case; + end Get_Entity_Type; + + ------------------- + -- Get_Scope_Num -- + ------------------- + + function Get_Scope_Num (N : Entity_Id) return Nat is + begin + return Scopes.Get (N).Num; + end Get_Scope_Num; + + ----------------------- + -- Is_Alfa_Reference -- + ----------------------- + + function Is_Alfa_Reference + (E : Entity_Id; + Typ : Character) return Boolean + is + begin + -- The only references of interest on callable entities are calls. On + -- non-callable entities, the only references of interest are reads + -- and writes. + + if Ekind (E) in Overloadable_Kind then + return Typ = 's'; + + -- References to constant objects are not considered in Alfa section, + -- as these will be translated as constants in the intermediate + -- language for formal verification, and should therefore never + -- appear in frame conditions. + + elsif Is_Constant_Object (E) then + return False; + + -- Objects of Task type or protected type are not Alfa references + + elsif Present (Etype (E)) + and then Ekind (Etype (E)) in Concurrent_Kind + then + return False; + + -- In all other cases, result is true for reference/modify cases, + -- and false for all other cases. + + else + return Typ = 'r' or else Typ = 'm'; + end if; + end Is_Alfa_Reference; + + ------------------- + -- Is_Alfa_Scope -- + ------------------- + + function Is_Alfa_Scope (E : Entity_Id) return Boolean is + begin + return Present (E) + and then not Is_Generic_Unit (E) + and then Renamed_Entity (E) = Empty + and then Get_Scope_Num (E) /= No_Scope; + end Is_Alfa_Scope; + + ---------------------------- + -- Is_Future_Scope_Entity -- + ---------------------------- + + function Is_Future_Scope_Entity + (E : Entity_Id; + S : Scope_Index) return Boolean + is + function Is_Past_Scope_Entity return Boolean; + -- Check whether entity E is in Alfa_Scope_Table at index strictly + -- lower than S. + + -------------------------- + -- Is_Past_Scope_Entity -- + -------------------------- + + function Is_Past_Scope_Entity return Boolean is + begin + for Index in Alfa_Scope_Table.First .. S - 1 loop + if Alfa_Scope_Table.Table (Index).Scope_Entity = E then + declare + Dummy : constant Alfa_Scope_Record := + Alfa_Scope_Table.Table (Index); + pragma Unreferenced (Dummy); + begin + return True; + end; + end if; + end loop; + + return False; + end Is_Past_Scope_Entity; + + -- Start of processing for Is_Future_Scope_Entity + + begin + for Index in S .. Alfa_Scope_Table.Last loop + if Alfa_Scope_Table.Table (Index).Scope_Entity = E then + return True; + end if; + end loop; + + -- If this assertion fails, this means that the scope which we are + -- looking for has been treated already, which reveals a problem in + -- the order of cross-references. + + pragma Assert (not Is_Past_Scope_Entity); + + return False; + end Is_Future_Scope_Entity; + + ------------------------ + -- Is_Global_Constant -- + ------------------------ + + function Is_Global_Constant (E : Entity_Id) return Boolean is + begin + return Ekind (E) = E_Constant + and then Ekind_In (Scope (E), E_Package, E_Package_Body); + end Is_Global_Constant; -------- -- Lt -- @@ -464,7 +553,7 @@ package body Alfa is if T1.Ent_Scope_File /= T2.Ent_Scope_File then return Dependency_Num (T1.Ent_Scope_File) < - Dependency_Num (T2.Ent_Scope_File); + Dependency_Num (T2.Ent_Scope_File); -- Second test: within same unit, sort by location of the scope of -- the entity definition. @@ -473,7 +562,7 @@ package body Alfa is Get_Scope_Num (T2.Key.Ent_Scope) then return Get_Scope_Num (T1.Key.Ent_Scope) < - Get_Scope_Num (T2.Key.Ent_Scope); + Get_Scope_Num (T2.Key.Ent_Scope); -- Third test: within same unit and scope, sort by location of -- entity definition. @@ -481,59 +570,68 @@ package body Alfa is elsif T1.Def /= T2.Def then return T1.Def < T2.Def; - -- Fourth test: if reference is in same unit as entity definition, - -- sort first. + else + -- Both entities must be equal at this point - elsif - T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun - then - return True; + pragma Assert (T1.Key.Ent = T2.Key.Ent); - elsif - T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun - then - return False; + -- Fourth test: if reference is in same unit as entity definition, + -- sort first. - -- Fifth test: if reference is in same unit and same scope as entity - -- definition, sort first. + if T1.Key.Lun /= T2.Key.Lun + and then T1.Ent_Scope_File = T1.Key.Lun + then + return True; - elsif T1.Ent_Scope_File = T1.Key.Lun - and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope - and then T1.Key.Ent_Scope = T1.Key.Ref_Scope - then - return True; - elsif T1.Ent_Scope_File = T1.Key.Lun - and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope - and then T2.Key.Ent_Scope = T2.Key.Ref_Scope - then - return False; + elsif T1.Key.Lun /= T2.Key.Lun + and then T2.Ent_Scope_File = T2.Key.Lun + then + return False; - -- Sixth test: for same entity, sort by reference location unit + -- Fifth test: if reference is in same unit and same scope as + -- entity definition, sort first. - elsif T1.Key.Lun /= T2.Key.Lun then - return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun); + elsif T1.Ent_Scope_File = T1.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T1.Key.Ent_Scope = T1.Key.Ref_Scope + then + return True; - -- Seventh test: for same entity, sort by reference location scope + elsif T2.Ent_Scope_File = T2.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T2.Key.Ent_Scope = T2.Key.Ref_Scope + then + return False; - elsif Get_Scope_Num (T1.Key.Ref_Scope) /= - Get_Scope_Num (T2.Key.Ref_Scope) - then - return Get_Scope_Num (T1.Key.Ref_Scope) < - Get_Scope_Num (T2.Key.Ref_Scope); + -- Sixth test: for same entity, sort by reference location unit - -- Eighth test: order of location within referencing unit + elsif T1.Key.Lun /= T2.Key.Lun then + return Dependency_Num (T1.Key.Lun) < + Dependency_Num (T2.Key.Lun); - elsif T1.Key.Loc /= T2.Key.Loc then - return T1.Key.Loc < T2.Key.Loc; + -- Seventh test: for same entity, sort by reference location scope - -- Finally, for two locations at the same address prefer the one that - -- does NOT have the type 'r', so that a modification or extension - -- takes preference, when there are more than one reference at the - -- same location. As a result, in the case of entities that are - -- in-out actuals, the read reference follows the modify reference. + elsif Get_Scope_Num (T1.Key.Ref_Scope) /= + Get_Scope_Num (T2.Key.Ref_Scope) + then + return Get_Scope_Num (T1.Key.Ref_Scope) < + Get_Scope_Num (T2.Key.Ref_Scope); - else - return T2.Key.Typ = 'r'; + -- Eighth test: order of location within referencing unit + + elsif T1.Key.Loc /= T2.Key.Loc then + return T1.Key.Loc < T2.Key.Loc; + + -- Finally, for two locations at the same address prefer the one + -- that does NOT have the type 'r', so that a modification or + -- extension takes preference, when there are more than one + -- reference at the same location. As a result, in the case of + -- entities that are in-out actuals, the read reference follows + -- the modify reference. + + else + return T2.Key.Typ = 'r'; + end if; end if; end Lt; @@ -546,308 +644,167 @@ package body Alfa is Rnums (Nat (To)) := Rnums (Nat (From)); end Move; - Heap : Entity_Id; + ------------------- + -- Set_Scope_Num -- + ------------------- + + procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is + begin + Scopes.Set (K => N, E => Scope_Rec'(Num => Num, Entity => N)); + end Set_Scope_Num; + + ------------------------ + -- Update_Scope_Range -- + ------------------------ + + procedure Update_Scope_Range + (S : Scope_Index; + From : Xref_Index; + To : Xref_Index) + is + begin + Alfa_Scope_Table.Table (S).From_Xref := From; + Alfa_Scope_Table.Table (S).To_Xref := To; + end Update_Scope_Range; + + -- Local variables + + Col : Nat; + From_Index : Xref_Index; + Line : Nat; + Loc : Source_Ptr; + Prev_Typ : Character; + Ref_Count : Nat; + Ref_Id : Entity_Id; + Ref_Name : String_Ptr; + Scope_Id : Scope_Index; -- Start of processing for Add_Alfa_Xrefs begin - for J in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop - Set_Scope_Num (N => Alfa_Scope_Table.Table (J).Scope_Entity, - Num => Alfa_Scope_Table.Table (J).Scope_Num); + for Index in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop + declare + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + begin + Set_Scope_Num (S.Scope_Entity, S.Scope_Num); + end; end loop; -- Set up the pointer vector for the sort - for J in 1 .. Nrefs loop - Rnums (J) := J; + for Index in 1 .. Nrefs loop + Rnums (Index) := Index; end loop; - -- Add dereferences to the set of regular references, by creating a - -- special "Heap" variable for these special references. - - Name_Len := Name_Of_Heap_Variable'Length; - Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; - - Atree.Unlock; - Nlists.Unlock; - Heap := Make_Defining_Identifier (Standard_Location, Name_Enter); - Atree.Lock; - Nlists.Lock; - - Set_Ekind (Heap, E_Variable); - Set_Is_Internal (Heap, True); - Set_Has_Fully_Qualified_Name (Heap); - - for J in Drefs.First .. Drefs.Last loop - Xrefs.Append (Drefs.Table (J)); - - -- Set entity at this point with newly created "Heap" variable - - Xrefs.Table (Xrefs.Last).Key.Ent := Heap; + for Index in Drefs.First .. Drefs.Last loop + Xrefs.Append (Drefs.Table (Index)); Nrefs := Nrefs + 1; Rnums (Nrefs) := Xrefs.Last; end loop; + -- Capture the definition Sloc values. As in the case of normal cross + -- references, we have to wait until now to get the correct value. + + for Index in 1 .. Nrefs loop + Xrefs.Table (Index).Def := Sloc (Xrefs.Table (Index).Key.Ent); + end loop; + -- Eliminate entries not appropriate for Alfa. Done prior to sorting -- cross-references, as it discards useless references which do not have -- a proper format for the comparison function (like no location). - Eliminate_Before_Sort : declare - NR : Nat; - - function Is_Alfa_Reference - (E : Entity_Id; - Typ : Character) return Boolean; - -- Return whether entity reference E meets Alfa requirements. Typ - -- is the reference type. - - function Is_Alfa_Scope (E : Entity_Id) return Boolean; - -- Return whether the entity or reference scope meets requirements - -- for being an Alfa scope. + Ref_Count := Nrefs; + Nrefs := 0; - function Is_Global_Constant (E : Entity_Id) return Boolean; - -- Return True if E is a global constant for which we should ignore - -- reads in Alfa. + for Index in 1 .. Ref_Count loop + declare + Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; - ----------------------- - -- Is_Alfa_Reference -- - ----------------------- - - function Is_Alfa_Reference - (E : Entity_Id; - Typ : Character) return Boolean - is begin - -- The only references of interest on callable entities are calls. - -- On non-callable entities, the only references of interest are - -- reads and writes. - - if Ekind (E) in Overloadable_Kind then - return Typ = 's'; - - -- References to constant objects are not considered in Alfa - -- section, as these will be translated as constants in the - -- intermediate language for formal verification, and should - -- therefore never appear in frame conditions. - - elsif Is_Constant_Object (E) then - return False; + if Alfa_Entities (Ekind (Ref.Ent)) + and then Alfa_References (Ref.Typ) + and then Is_Alfa_Scope (Ref.Ent_Scope) + and then Is_Alfa_Scope (Ref.Ref_Scope) + and then not Is_Global_Constant (Ref.Ent) + and then Is_Alfa_Reference (Ref.Ent, Ref.Typ) - -- Objects of Task type or protected type are not Alfa references + -- Discard references from unknown scopes, e.g. generic scopes - elsif Present (Etype (E)) - and then Ekind (Etype (E)) in Concurrent_Kind - then - return False; - - -- In all other cases, result is true for reference/modify cases, - -- and false for all other cases. - - else - return Typ = 'r' or else Typ = 'm'; - end if; - end Is_Alfa_Reference; - - ------------------- - -- Is_Alfa_Scope -- - ------------------- - - function Is_Alfa_Scope (E : Entity_Id) return Boolean is - begin - return Present (E) - and then not Is_Generic_Unit (E) - and then Renamed_Entity (E) = Empty - and then Get_Scope_Num (E) /= No_Scope; - end Is_Alfa_Scope; - - ------------------------ - -- Is_Global_Constant -- - ------------------------ - - function Is_Global_Constant (E : Entity_Id) return Boolean is - begin - return Ekind (E) = E_Constant - and then Ekind_In (Scope (E), E_Package, E_Package_Body); - end Is_Global_Constant; - - -- Start of processing for Eliminate_Before_Sort - - begin - NR := Nrefs; - Nrefs := 0; - - for J in 1 .. NR loop - if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent)) - and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ) - and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope) - and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope) - and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent) - and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent, - Xrefs.Table (Rnums (J)).Key.Typ) + and then Get_Scope_Num (Ref.Ent_Scope) /= No_Scope + and then Get_Scope_Num (Ref.Ref_Scope) /= No_Scope then Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); + Rnums (Nrefs) := Rnums (Index); end if; - end loop; - end Eliminate_Before_Sort; + end; + end loop; -- Sort the references Sorting.Sort (Integer (Nrefs)); - Eliminate_After_Sort : declare - NR : Nat; + -- Eliminate duplicate entries - Crloc : Source_Ptr; - -- Current reference location + -- We need this test for Ref_Count because if we force ALI file + -- generation in case of errors detected, it may be the case that + -- Nrefs is 0, so we should not reset it here. - Prevt : Character; - -- reference kind of previous reference + if Nrefs >= 2 then + Ref_Count := Nrefs; + Nrefs := 1; - begin - -- Eliminate duplicate entries - - -- We need this test for NR because if we force ALI file generation - -- in case of errors detected, it may be the case that Nrefs is 0, so - -- we should not reset it here - - if Nrefs >= 2 then - NR := Nrefs; - Nrefs := 1; + for Index in 2 .. Ref_Count loop + if Xrefs.Table (Rnums (Index)) /= + Xrefs.Table (Rnums (Nrefs)) + then + Nrefs := Nrefs + 1; + Rnums (Nrefs) := Rnums (Index); + end if; + end loop; + end if; - for J in 2 .. NR loop - if Xrefs.Table (Rnums (J)) /= - Xrefs.Table (Rnums (Nrefs)) - then - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); - end if; - end loop; - end if; + -- Eliminate the reference if it is at the same location as the previous + -- one, unless it is a read-reference indicating that the entity is an + -- in-out actual in a call. - -- Eliminate the reference if it is at the same location as the - -- previous one, unless it is a read-reference indicating that the - -- entity is an in-out actual in a call. + Ref_Count := Nrefs; + Nrefs := 0; + Loc := No_Location; + Prev_Typ := 'm'; - NR := Nrefs; - Nrefs := 0; - Crloc := No_Location; - Prevt := 'm'; + for Index in 1 .. Ref_Count loop + declare + Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; - for J in 1 .. NR loop - if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc - or else (Prevt = 'm' - and then Xrefs.Table (Rnums (J)).Key.Typ = 'r') + begin + if Ref.Loc /= Loc + or else (Prev_Typ = 'm' and then Ref.Typ = 'r') then - Crloc := Xrefs.Table (Rnums (J)).Key.Loc; - Prevt := Xrefs.Table (Rnums (J)).Key.Typ; + Loc := Ref.Loc; + Prev_Typ := Ref.Typ; Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); + Rnums (Nrefs) := Rnums (Index); end if; - end loop; - end Eliminate_After_Sort; - - -- Initialize loop + end; + end loop; - Cur_Scope_Idx := 1; - From_Xref_Idx := 1; - Cur_Entity := Empty; + -- The two steps have eliminated all references, nothing to do if Alfa_Scope_Table.Last = 0 then return; end if; + Ref_Id := Empty; + Scope_Id := 1; + From_Index := 1; + -- Loop to output references for Refno in 1 .. Nrefs loop - Add_One_Xref : declare - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Cur_Scope return Node_Id; - -- Return scope entity which corresponds to index Cur_Scope_Idx in - -- table Alfa_Scope_Table. - - function Get_Entity_Type (E : Entity_Id) return Character; - -- Return a character representing the type of entity - - function Is_Future_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index - -- Cur_Scope_Idx or higher. - - function Is_Past_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index strictly - -- lower than Cur_Scope_Idx. - - --------------- - -- Cur_Scope -- - --------------- - - function Cur_Scope return Node_Id is - begin - return Alfa_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity; - end Cur_Scope; - - --------------------- - -- Get_Entity_Type -- - --------------------- - - function Get_Entity_Type (E : Entity_Id) return Character is - C : Character; - begin - case Ekind (E) is - when E_Out_Parameter => C := '<'; - when E_In_Out_Parameter => C := '='; - when E_In_Parameter => C := '>'; - when others => C := '*'; - end case; - return C; - end Get_Entity_Type; - - ---------------------------- - -- Is_Future_Scope_Entity -- - ---------------------------- - - function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is - begin - for J in Cur_Scope_Idx .. Alfa_Scope_Table.Last loop - if E = Alfa_Scope_Table.Table (J).Scope_Entity then - return True; - end if; - end loop; - - -- If this assertion fails, this means that the scope which we - -- are looking for has been treated already, which reveals a - -- problem in the order of cross-references. - - pragma Assert (not Is_Past_Scope_Entity (E)); - - return False; - end Is_Future_Scope_Entity; - - -------------------------- - -- Is_Past_Scope_Entity -- - -------------------------- - - function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is - begin - for J in Alfa_Scope_Table.First .. Cur_Scope_Idx - 1 loop - if E = Alfa_Scope_Table.Table (J).Scope_Entity then - return True; - end if; - end loop; - - return False; - end Is_Past_Scope_Entity; - - --------------------- - -- Local Variables -- - --------------------- - - XE : Xref_Entry renames Xrefs.Table (Rnums (Refno)); + declare + Ref_Entry : Xref_Entry renames Xrefs.Table (Rnums (Refno)); + Ref : Xref_Key renames Ref_Entry.Key; begin -- If this assertion fails, the scope which we are looking for is @@ -855,61 +812,57 @@ package body Alfa is -- construction of the scope table, or an erroneous scope for the -- current cross-reference. - pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope)); + pragma Assert (Is_Future_Scope_Entity (Ref.Ent_Scope, Scope_Id)); -- Update the range of cross references to which the current scope -- refers to. This may be the empty range only for the first scope -- considered. - if XE.Key.Ent_Scope /= Cur_Scope then - Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := - From_Xref_Idx; - Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := - Alfa_Xref_Table.Last; - From_Xref_Idx := Alfa_Xref_Table.Last + 1; + if Ref.Ent_Scope /= Entity_Of_Scope (Scope_Id) then + Update_Scope_Range + (S => Scope_Id, + From => From_Index, + To => Alfa_Xref_Table.Last); + + From_Index := Alfa_Xref_Table.Last + 1; end if; - while XE.Key.Ent_Scope /= Cur_Scope loop - Cur_Scope_Idx := Cur_Scope_Idx + 1; - pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last); + while Ref.Ent_Scope /= Entity_Of_Scope (Scope_Id) loop + Scope_Id := Scope_Id + 1; + pragma Assert (Scope_Id <= Alfa_Scope_Table.Last); end loop; - if XE.Key.Ent /= Cur_Entity then - Cur_Entity_Name := - new String'(Unique_Name (XE.Key.Ent)); + if Ref.Ent /= Ref_Id then + Ref_Name := new String'(Unique_Name (Ref.Ent)); end if; - if XE.Key.Ent = Heap then - Alfa_Xref_Table.Append ( - (Entity_Name => Cur_Entity_Name, - Entity_Line => 0, - Etype => Get_Entity_Type (XE.Key.Ent), - Entity_Col => 0, - File_Num => Dependency_Num (XE.Key.Lun), - Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), - Rtype => XE.Key.Typ, - Col => Int (Get_Column_Number (XE.Key.Loc)))); - + if Ref.Ent = Heap then + Line := 0; + Col := 0; else - Alfa_Xref_Table.Append ( - (Entity_Name => Cur_Entity_Name, - Entity_Line => Int (Get_Logical_Line_Number (XE.Def)), - Etype => Get_Entity_Type (XE.Key.Ent), - Entity_Col => Int (Get_Column_Number (XE.Def)), - File_Num => Dependency_Num (XE.Key.Lun), - Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), - Rtype => XE.Key.Typ, - Col => Int (Get_Column_Number (XE.Key.Loc)))); + Line := Int (Get_Logical_Line_Number (Ref_Entry.Def)); + Col := Int (Get_Column_Number (Ref_Entry.Def)); end if; - end Add_One_Xref; + + Alfa_Xref_Table.Append ( + (Entity_Name => Ref_Name, + Entity_Line => Line, + Etype => Get_Entity_Type (Ref.Ent), + Entity_Col => Col, + File_Num => Dependency_Num (Ref.Lun), + Scope_Num => Get_Scope_Num (Ref.Ref_Scope), + Line => Int (Get_Logical_Line_Number (Ref.Loc)), + Rtype => Ref.Typ, + Col => Int (Get_Column_Number (Ref.Loc)))); + end; end loop; -- Update the range of cross references to which the scope refers to - Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx; - Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := Alfa_Xref_Table.Last; + Update_Scope_Range + (S => Scope_Id, + From => From_Index, + To => Alfa_Xref_Table.Last); end Add_Alfa_Xrefs; ------------------ @@ -917,6 +870,9 @@ package body Alfa is ------------------ procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is + D1 : Nat; + D2 : Nat; + begin -- Cross-references should have been computed first @@ -926,8 +882,28 @@ package body Alfa is -- Generate file and scope Alfa information - for D in 1 .. Num_Sdep loop - Add_Alfa_File (U => Sdep_Table (D), D => D); + D1 := 1; + while D1 <= Num_Sdep loop + + -- In rare cases, when treating the library-level instantiation of a + -- generic, two consecutive units refer to the same compilation unit + -- node and entity. In that case, treat them as a single unit for the + -- sake of Alfa cross references by passing to Add_Alfa_File. + + if D1 < Num_Sdep + and then Cunit_Entity (Sdep_Table (D1)) = + Cunit_Entity (Sdep_Table (D1 + 1)) + then + D2 := D1 + 1; + else + D2 := D1; + end if; + + Add_Alfa_File + (Ubody => Sdep_Table (D1), + Uspec => Sdep_Table (D2), + Dspec => D2); + D1 := D2 + 1; end loop; -- Fill in the spec information when relevant @@ -965,8 +941,7 @@ package body Alfa is Entity_Hash_Table.Get (Spec_Entity); begin - -- Spec of generic may be missing, in which case Spec_Scope is - -- zero. + -- Generic spec may be missing in which case Spec_Scope is zero if Spec_Entity /= Srec.Scope_Entity and then Spec_Scope /= 0 @@ -1020,9 +995,7 @@ package body Alfa is Result := N; end if; - loop - exit when No (Result); - + while Present (Result) loop case Nkind (Result) is when N_Package_Specification => Result := Defining_Unit_Name (Result); @@ -1068,7 +1041,7 @@ package body Alfa is Result := Defining_Identifier (Result); end if; - -- Do no return a scope without a proper location + -- Do not return a scope without a proper location if Present (Result) and then Sloc (Result) = No_Location @@ -1097,36 +1070,67 @@ package body Alfa is (N : Node_Id; Typ : Character := 'r') is - Indx : Nat; - Ref : Source_Ptr; + procedure Create_Heap; + -- Create and decorate the special entity which denotes the heap + + ----------------- + -- Create_Heap -- + ----------------- + + procedure Create_Heap is + begin + Name_Len := Name_Of_Heap_Variable'Length; + Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; + + Heap := Make_Defining_Identifier (Standard_Location, Name_Enter); + + Set_Ekind (Heap, E_Variable); + Set_Is_Internal (Heap, True); + Set_Has_Fully_Qualified_Name (Heap); + end Create_Heap; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Index : Nat; Ref_Scope : Entity_Id; + -- Start of processing for Generate_Dereference + begin - Ref := Original_Location (Sloc (N)); - if Ref > No_Location then + if Loc > No_Location then Drefs.Increment_Last; - Indx := Drefs.Last; + Index := Drefs.Last; + + declare + Deref_Entry : Xref_Entry renames Drefs.Table (Index); + Deref : Xref_Key renames Deref_Entry.Key; + + begin + if No (Heap) then + Create_Heap; + end if; - Ref_Scope := Enclosing_Subprogram_Or_Package (N); + Ref_Scope := Enclosing_Subprogram_Or_Package (N); - -- Entity is filled later on with the special "Heap" variable + Deref.Ent := Heap; + Deref.Loc := Loc; + Deref.Typ := Typ; - Drefs.Table (Indx).Key.Ent := Empty; + -- It is as if the special "Heap" was defined in every scope where + -- it is referenced. - Drefs.Table (Indx).Def := No_Location; - Drefs.Table (Indx).Key.Loc := Ref; - Drefs.Table (Indx).Key.Typ := Typ; + Deref.Eun := Get_Code_Unit (Loc); + Deref.Lun := Get_Code_Unit (Loc); - -- It is as if the special "Heap" was defined in every scope where it - -- is referenced. + Deref.Ref_Scope := Ref_Scope; + Deref.Ent_Scope := Ref_Scope; - Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref); - Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref); + Deref_Entry.Def := No_Location; - Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope; - Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope; - Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope); + Deref_Entry.Ent_Scope_File := Get_Code_Unit (N); + end; end if; end Generate_Dereference; @@ -1161,6 +1165,14 @@ package body Alfa is Lu := Proper_Body (Lu); end if; + -- Do not add scopes for generic units + + if Nkind (Lu) = N_Package_Body + and then Ekind (Corresponding_Spec (Lu)) in Generic_Unit_Kind + then + return; + end if; + -- Call Process on all declarations if Nkind (Lu) in N_Declaration @@ -1183,18 +1195,8 @@ package body Alfa is elsif Nkind (Lu) = N_Package_Body then Traverse_Package_Body (Lu, Process, Inside_Stubs); - -- ??? TBD - - elsif Nkind (Lu) = N_Generic_Package_Declaration then - null; - - -- ??? TBD - - elsif Nkind (Lu) in N_Generic_Instantiation then - null; - -- All other cases of compilation units (e.g. renamings), are not - -- declarations. + -- declarations, or else generic declarations which are ignored. else null; @@ -1233,11 +1235,6 @@ package body Alfa is when N_Package_Declaration => Traverse_Package_Declaration (N, Process, Inside_Stubs); - -- Generic package declaration ??? TBD - - when N_Generic_Package_Declaration => - null; - -- Package body when N_Package_Body => @@ -1264,11 +1261,6 @@ package body Alfa is when N_Subprogram_Declaration => null; - -- Generic subprogram declaration ??? TBD - - when N_Generic_Subprogram_Declaration => - null; - -- Subprogram body when N_Subprogram_Body => @@ -1355,6 +1347,8 @@ package body Alfa is Traverse_Declarations_Or_Statements (Statements (N), Process, Inside_Stubs); + -- Generic declarations are ignored + when others => null; end case; @@ -1429,7 +1423,8 @@ package body Alfa is procedure Traverse_Subprogram_Body (N : Node_Id; Process : Node_Processing; - Inside_Stubs : Boolean) is + Inside_Stubs : Boolean) + is begin Traverse_Declarations_Or_Statements (Declarations (N), Process, Inside_Stubs); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 0e8337f70c6..b6595b336a4 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -161,6 +161,9 @@ package body Lib.Xref is -- Local Subprograms -- ------------------------ + procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type); + -- Add an entry to the tables of Xref_Entries, avoiding duplicates + procedure Generate_Prim_Op_References (Typ : Entity_Id); -- For a tagged type, generate implicit references to its primitive -- operations, for source navigation. This is done right before emitting @@ -170,9 +173,6 @@ package body Lib.Xref is function Lt (T1, T2 : Xref_Entry) return Boolean; -- Order cross-references - procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type); - -- Add an entry to the tables of Xref_Entries, avoiding duplicates - --------------- -- Add_Entry -- --------------- @@ -373,23 +373,16 @@ package body Lib.Xref is Set_Ref : Boolean := True; Force : Boolean := False) is - Nod : Node_Id; - Ref : Source_Ptr; - Def : Source_Ptr; - Ent : Entity_Id; - - Actual_Typ : Character := Typ; - - Ref_Scope : Entity_Id; + Actual_Typ : Character := Typ; + Call : Node_Id; + Def : Source_Ptr; + Ent : Entity_Id; Ent_Scope : Entity_Id; - Ent_Scope_File : Unit_Number_Type; - - Call : Node_Id; - Formal : Entity_Id; - -- Used for call to Find_Actual - - Kind : Entity_Kind; - -- If Formal is non-Empty, then its Ekind, otherwise E_Void + Formal : Entity_Id; + Kind : Entity_Kind; + Nod : Node_Id; + Ref : Source_Ptr; + Ref_Scope : Entity_Id; function Get_Through_Renamings (E : Entity_Id) return Entity_Id; -- Get the enclosing entity through renamings, which may come from @@ -639,6 +632,14 @@ package body Lib.Xref is or else Typ = 'i' or else Typ = 'k' or else (Typ = 'b' and then Is_Generic_Instance (E)) + + -- Allow the generation of references to reads, writes and calls + -- in Alfa mode when the related context comes from an instance. + + or else + (Alfa_Mode + and then In_Extended_Main_Code_Unit (N) + and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')) then null; else @@ -884,37 +885,31 @@ package body Lib.Xref is and then Sloc (E) > No_Location and then Sloc (N) > No_Location - -- We ignore references from within an instance, except for default - -- subprograms, for which we generate an implicit reference. + -- Ignore references from within an instance. The only exceptions to + -- this are default subprograms, for which we generate an implicit + -- reference and compilations in Alfa_Mode. and then - (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i') + (Instantiation_Location (Sloc (N)) = No_Location + or else Typ = 'i' + or else Alfa_Mode) - -- Ignore dummy references + -- Ignore dummy references and then Typ /= ' ' then - if Nkind (N) = N_Identifier - or else - Nkind (N) = N_Defining_Identifier - or else - Nkind (N) in N_Op - or else - Nkind (N) = N_Defining_Operator_Symbol - or else - Nkind (N) = N_Operator_Symbol - or else - (Nkind (N) = N_Character_Literal - and then Sloc (Entity (N)) /= Standard_Location) - or else - Nkind (N) = N_Defining_Character_Literal + if Nkind_In (N, N_Identifier, + N_Defining_Identifier, + N_Defining_Operator_Symbol, + N_Operator_Symbol, + N_Defining_Character_Literal) + or else Nkind (N) in N_Op + or else (Nkind (N) = N_Character_Literal + and then Sloc (Entity (N)) /= Standard_Location) then Nod := N; - elsif Nkind (N) = N_Expanded_Name - or else - Nkind (N) = N_Selected_Component - then + elsif Nkind_In (N, N_Expanded_Name, N_Selected_Component) then Nod := Selector_Name (N); else @@ -999,18 +994,18 @@ package body Lib.Xref is -- Record reference to entity - Ref := Original_Location (Sloc (Nod)); - Def := Original_Location (Sloc (Ent)); - if Actual_Typ = 'p' - and then Is_Subprogram (N) - and then Present (Overridden_Operation (N)) + and then Is_Subprogram (Nod) + and then Present (Overridden_Operation (Nod)) then Actual_Typ := 'P'; end if; if Alfa_Mode then - Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); + Ref := Sloc (Nod); + Def := Sloc (Ent); + + Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (Nod); Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); -- Since we are reaching through renamings in Alfa mode, we may @@ -1022,22 +1017,39 @@ package body Lib.Xref is return; end if; - Ent_Scope_File := Get_Source_Unit (Ent_Scope); + Add_Entry + ((Ent => Ent, + Loc => Ref, + Typ => Actual_Typ, + Eun => Get_Code_Unit (Def), + Lun => Get_Code_Unit (Ref), + Ref_Scope => Ref_Scope, + Ent_Scope => Ent_Scope), + Ent_Scope_File => Get_Code_Unit (Ent)); + else - Ref_Scope := Empty; - Ent_Scope := Empty; - Ent_Scope_File := No_Unit; - end if; + Ref := Original_Location (Sloc (Nod)); + Def := Original_Location (Sloc (Ent)); - Add_Entry - ((Ent => Ent, - Loc => Ref, - Typ => Actual_Typ, - Eun => Get_Source_Unit (Def), - Lun => Get_Source_Unit (Ref), - Ref_Scope => Ref_Scope, - Ent_Scope => Ent_Scope), - Ent_Scope_File => Ent_Scope_File); + -- If this is an operator symbol, skip the initial + -- quote, for navigation purposes. + + if Nkind (N) = N_Defining_Operator_Symbol + or else Nkind (Nod) = N_Operator_Symbol + then + Ref := Ref + 1; + end if; + + Add_Entry + ((Ent => Ent, + Loc => Ref, + Typ => Actual_Typ, + Eun => Get_Source_Unit (Def), + Lun => Get_Source_Unit (Ref), + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); + end if; end if; end Generate_Reference; @@ -1715,11 +1727,24 @@ package body Lib.Xref is -- since at the time the reference or definition is made, private -- types may be swapped, and the Sloc value may be incorrect. We -- also set up the pointer vector for the sort. + -- For user-defined operators we need to skip the initial + -- quote and point to the first character of the name, for + -- navigation purposes. for J in 1 .. Nrefs loop - Rnums (J) := J; - Xrefs.Table (J).Def := - Original_Location (Sloc (Xrefs.Table (J).Key.Ent)); + declare + E : constant Entity_Id := Xrefs.Table (J).Key.Ent; + Loc : constant Source_Ptr := Original_Location (Sloc (E)); + + begin + Rnums (J) := J; + + if Nkind (E) = N_Defining_Operator_Symbol then + Xrefs.Table (J).Def := Loc + 1; + else + Xrefs.Table (J).Def := Loc; + end if; + end; end loop; -- Sort the references @@ -2434,6 +2459,8 @@ package body Lib.Xref is end Output_Refs; end Output_References; +-- Start of elaboration for Lib.Xref + begin -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr, -- because it's not an access type. diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index ecac26fabb3..7bdc1582b5e 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -605,10 +605,13 @@ package Lib.Xref is (CU : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean); - -- This procedure is undocumented ??? + -- Call Process on all declarations in compilation unit CU. If + -- Inside_Stubs is True, then the body of stubs is also traversed. + -- Generic declarations are ignored. procedure Traverse_All_Compilation_Units (Process : Node_Processing); - -- Call Process on all declarations through all compilation units + -- Call Process on all declarations through all compilation units. + -- Generic declarations are ignored. procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat); -- Collect Alfa information from library units (for files and scopes) diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index a1dc37cf51c..e59e67eb8e8 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -987,6 +987,11 @@ package Opt is -- GNATMAKE -- Set to True when an object directory is specified with option -D + Object_Path_File_Name : String_Ptr := null; + -- GNAT2WHY + -- Path of the temporary file that contains a list of object directories + -- passed by -gnateO=<obj_pat_file>. + One_Compilation_Per_Obj_Dir : Boolean := False; -- GNATMAKE, GPRBUILD -- Set to True with switch --single-compile-per-obj-dir. When True, there diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 8da01c2468a..9a2e7ee26f3 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -444,6 +444,15 @@ package body Osint is -- Start of processing for Add_Default_Search_Dirs begin + -- If there was a -gnateO switch, add all object directories from the + -- file given in argument to the library search list. + + if Object_Path_File_Name /= null then + Path_File_Name := String_Access (Object_Path_File_Name); + pragma Assert (Path_File_Name'Length > 0); + Get_Dirs_From_File (Additional_Source_Dir => False); + end if; + -- After the locations specified on the command line, the next places -- to look for files are the directories specified by the appropriate -- environment variable. Get this value, extract the directory names diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index a4fc33412e4..48663f519e8 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -324,7 +324,8 @@ package Osint is procedure Add_Default_Search_Dirs; -- This routine adds the default search dirs indicated by the environment - -- variables and sdefault package. + -- variables and sdefault package, as well as the library search dirs set + -- by option -gnateO for GNAT2WHY. procedure Add_Lib_Search_Dir (Dir : String); -- Add Dir at the end of the library file search path diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index ba569e119e6..8d3d855e789 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -226,6 +226,7 @@ package body Prj.Attr is "Lainclude_switches#" & "Sainclude_path#" & "Sainclude_path_file#" & + "Laobject_path_switches#" & -- package Builder diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 284f9f0b6e5..01b39c69d73 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1440,6 +1440,12 @@ package body Prj.Nmsc is From_List => Element.Value.Values, In_Tree => Data.Tree); + when Name_Object_Path_Switches => + Put (Into_List => + Lang_Index.Config.Object_Path_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + -- Attribute Compiler_Pic_Option (<language>) when Name_Pic_Option => diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index c8c5958aad5..9a5e2607aa1 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -296,7 +296,7 @@ package body Prj is when Makefile => return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix); - when ALI_File => + when ALI_File | ALI_Closure => return Extend_Name (Source_File_Name, ALI_Dependency_Suffix); end case; end Dependency_Name; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 877d1b59b39..a95ac732813 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -298,9 +298,26 @@ package Prj is -- Type for the kind of language. All languages are file based, except Ada -- which is unit based. - type Dependency_File_Kind is (None, Makefile, ALI_File); - -- Type of dependency to be checked: no dependency file, Makefile fragment - -- or ALI file (for Ada). + -- Type of dependency to be checked + + type Dependency_File_Kind is + (None, + -- There is no dependency file, the source must always be recompiled + + Makefile, + -- The dependency file is a Makefile fragment indicating all the files + -- the source depends on. If the object file or the dependency file is + -- more recent than any of these files, the source must be recompiled. + + ALI_File, + -- The dependency file is an ALI file and the source must be recompiled + -- if the object or ALI file is more recent than any of the sources + -- listed in the D lines. + + ALI_Closure); + -- The dependency file is an ALI file and the source must be recompiled + -- if the object or ALI file is more recent than any source in the full + -- closure. Makefile_Dependency_Suffix : constant String := ".d"; ALI_Dependency_Suffix : constant String := ".ali"; @@ -472,6 +489,11 @@ package Prj is -- are used to specify the object file. The object file name is appended -- to the last switch in the list. Example: ("-o", ""). + Object_Path_Switches : Name_List_Index := No_Name_List; + -- List of switches to specify to the compiler the path name of a + -- temporary file containing the list of object directories in the + -- correct order. + Compilation_PIC_Option : Name_List_Index := No_Name_List; -- The option(s) to compile a source in Position Independent Code for -- shared libraries. Specified in the configuration. When not specified, @@ -602,6 +624,7 @@ package Prj is Source_File_Switches => No_Name_List, Object_File_Suffix => No_Name, Object_File_Switches => No_Name_List, + Object_Path_Switches => No_Name_List, Compilation_PIC_Option => No_Name_List, Object_Generated => True, Objects_Linked => True, @@ -1233,6 +1256,10 @@ package Prj is -- The path name of the exec directory of this project file. Default is -- equal to Object_Directory. + Object_Path_File : Path_Name_Type := No_Path; + -- Store the name of the temporary file that contains the list of object + -- directories, when attribute Object_Path_Switches is declared. + ------------- -- Library -- ------------- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 88e61dc893c..e02f575d7d5 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -211,6 +211,7 @@ package Rtsfind is System_Arith_64, System_AST_Handling, System_Assertions, + System_Atomic_Primitives, System_Aux_DEC, System_Bit_Ops, System_Boolean_Array_Operations, @@ -730,6 +731,19 @@ package Rtsfind is RE_Assert_Failure, -- System.Assertions RE_Raise_Assert_Failure, -- System.Assertions + RE_Atomic_Compare_Exchange_8, -- System.Atomic_Primitives + RE_Atomic_Compare_Exchange_16, -- System.Atomic_Primitives + RE_Atomic_Compare_Exchange_32, -- System.Atomic_Primitives + RE_Atomic_Compare_Exchange_64, -- System.Atomic_Primitives + RE_Atomic_Load_8, -- System.Atomic_Primitives + RE_Atomic_Load_16, -- System.Atomic_Primitives + RE_Atomic_Load_32, -- System.Atomic_Primitives + RE_Atomic_Load_64, -- System.Atomic_Primitives + RE_Uint8, -- System.Atomic_Primitives + RE_Uint16, -- System.Atomic_Primitives + RE_Uint32, -- System.Atomic_Primitives + RE_Uint64, -- System.Atomic_Primitives + RE_AST_Handler, -- System.Aux_DEC RE_Import_Value, -- System.Aux_DEC RE_No_AST_Handler, -- System.Aux_DEC @@ -1938,6 +1952,19 @@ package Rtsfind is RE_Assert_Failure => System_Assertions, RE_Raise_Assert_Failure => System_Assertions, + RE_Atomic_Compare_Exchange_8 => System_Atomic_Primitives, + RE_Atomic_Compare_Exchange_16 => System_Atomic_Primitives, + RE_Atomic_Compare_Exchange_32 => System_Atomic_Primitives, + RE_Atomic_Compare_Exchange_64 => System_Atomic_Primitives, + RE_Atomic_Load_8 => System_Atomic_Primitives, + RE_Atomic_Load_16 => System_Atomic_Primitives, + RE_Atomic_Load_32 => System_Atomic_Primitives, + RE_Atomic_Load_64 => System_Atomic_Primitives, + RE_Uint8 => System_Atomic_Primitives, + RE_Uint16 => System_Atomic_Primitives, + RE_Uint32 => System_Atomic_Primitives, + RE_Uint64 => System_Atomic_Primitives, + RE_AST_Handler => System_Aux_DEC, RE_Import_Value => System_Aux_DEC, RE_No_AST_Handler => System_Aux_DEC, diff --git a/gcc/ada/s-atopri.ads b/gcc/ada/s-atopri.ads new file mode 100644 index 00000000000..c8c75f2ff72 --- /dev/null +++ b/gcc/ada/s-atopri.ads @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2012, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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. -- +-- -- +------------------------------------------------------------------------------ + +-- ??? Need header saying what this unit is!!! + +package System.Atomic_Primitives is + pragma Preelaborate; + + type uint8 is mod 2**8 + with Size => 8; + + type uint16 is mod 2**16 + with Size => 16; + + type uint32 is mod 2**32 + with Size => 32; + + type uint64 is mod 2**64 + with Size => 64; + + Relaxed : constant := 0; + Consume : constant := 1; + Acquire : constant := 2; + Release : constant := 3; + Acq_Rel : constant := 4; + Seq_Cst : constant := 5; + Last : constant := 6; + + subtype Mem_Model is Integer range Relaxed .. Last; + + function Atomic_Compare_Exchange_8 + (X : Address; + X_Old : uint8; + X_Copy : uint8) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_8, + "__sync_bool_compare_and_swap_1"); + + -- ??? Should use __atomic_compare_exchange_1 (doesn't work yet): + -- function Atomic_Compare_Exchange_8 + -- (X : Address; + -- X_Old : Address; + -- X_Copy : uint8; + -- Success_Model : Mem_Model := Seq_Cst; + -- Failure_Model : Mem_Model := Seq_Cst) return Boolean; + -- pragma Import (Intrinsic, + -- Atomic_Compare_Exchange_8, + -- "__atomic_compare_exchange_1"); + + function Atomic_Compare_Exchange_16 + (X : Address; + X_Old : uint16; + X_Copy : uint16) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_16, + "__sync_bool_compare_and_swap_2"); + + function Atomic_Compare_Exchange_32 + (X : Address; + X_Old : uint32; + X_Copy : uint32) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_32, + "__sync_bool_compare_and_swap_4"); + + function Atomic_Compare_Exchange_64 + (X : Address; + X_Old : uint64; + X_Copy : uint64) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_64, + "__sync_bool_compare_and_swap_8"); + + function Atomic_Load_8 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint8; + pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); + + function Atomic_Load_16 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint16; + pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); + + function Atomic_Load_32 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint32; + pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); + + function Atomic_Load_64 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint64; + pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); + +end System.Atomic_Primitives; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 2e50d3dc73b..503d1f40d43 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -314,6 +314,9 @@ package body Sem is when N_Label => Analyze_Label (N); + when N_Loop_Parameter_Specification => + Analyze_Loop_Parameter_Specification (N); + when N_Loop_Statement => Analyze_Loop_Statement (N); @@ -681,7 +684,6 @@ package body Sem is N_Generic_Association | N_Index_Or_Discriminant_Constraint | N_Iteration_Scheme | - N_Loop_Parameter_Specification | N_Mod_Clause | N_Modular_Type_Definition | N_Ordinary_Fixed_Point_Definition | diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 77db15ed21e..10af9e2d054 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -323,7 +323,7 @@ package body Sem_Attr is -- type or a private type for which no full view has been given. procedure Check_Object_Reference (P : Node_Id); - -- Check that P (the prefix of the attribute) is an object reference + -- Check that P is an object reference procedure Check_Program_Unit; -- Verify that prefix of attribute N is a program unit @@ -5202,8 +5202,13 @@ package body Sem_Attr is when Attribute_Valid_Scalars => Check_E0; - Check_Type; - -- More stuff TBD ??? + Check_Object_Reference (P); + + if No_Scalar_Parts (P_Type) then + Error_Attr_P ("?attribute % always True, no scalars to check"); + end if; + + Set_Etype (N, Standard_Boolean); ----------- -- Value -- diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 71ac668c757..7258593aabf 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -554,12 +554,33 @@ package Sem_Attr is ------------------- Attribute_Valid_Scalars => True, - -- Obj'Valid_Scalars applies to objects of scalar types, on which it is - -- equivalent to Obj'Valid, and objects of array and record types, on - -- which it amounts to applying 'Valid to each subcomponent of Obj. It - -- does not apply to prefixes of classwide type, or of a formal generic - -- type that has an unknown discriminant (which could be instantiated - -- with a classwide type). + -- Obj'Valid_Scalars can be applied to any object. The result depends + -- on the type of the object: + -- + -- For a scalar type, the result is the same as obj'Valid + -- + -- For an array object, the result is True if the result of applying + -- Valid_Scalars to every component is True. For an empty array the + -- result is True. + -- + -- For a record object, the result is True if the result of applying + -- Valid_Scalars to every component is True. For class-wide types, + -- only the components of the base type are checked. For variant + -- records, only the components actually present are checked. The + -- discriminants, if any, are also checked. If there are no components + -- or discriminants, the result is True. + -- + -- For any other type that has discriminants, the result is True if + -- the result of applying Valid_Scalars to each discriminant is True. + -- + -- For all other types, the result is always True + -- + -- A warning is given for a trivially True result, when the attribute + -- is applied to an object that is not of scalar, array, or record + -- type, or in the composite case if no scalar subcomponents exist. For + -- a variant record, the warning is given only if none of the variants + -- have scalar subcomponents. In addition, the warning is suppressed + -- for private types, or generic formal types in an instance. ---------------- -- Value_Size -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 054772964ef..d0525633681 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3704,7 +3704,6 @@ package body Sem_Ch12 is or else Might_Inline_Subp) and then not Is_Actual_Pack and then not Inline_Now - and then not Alfa_Mode and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics and then ASIS_Mode)); @@ -4405,9 +4404,6 @@ package body Sem_Ch12 is Parent_Installed : Boolean := False; Renaming_List : List_Id; - Save_Style_Check : constant Boolean := Style_Check; - -- Save style check mode for restore on exit - procedure Analyze_Instance_And_Renamings; -- The instance must be analyzed in a context that includes the mappings -- of generic parameters into actuals. We create a package declaration @@ -4588,11 +4584,13 @@ package body Sem_Ch12 is Instantiation_Node := N; - -- Turn off style checking in instances. If the check is enabled on the - -- generic unit, a warning in an instance would just be noise. If not - -- enabled on the generic, then a warning in an instance is just wrong. + -- For package instantiations we turn off style checks, because they + -- will have been emitted in the generic. For subprogram instantiations + -- we want to apply at least the check on overriding indicators so we + -- do not modify the style check status. - Style_Check := False; + -- The renaming declarations for the actuals do not come from source and + -- will not generate spurious warnings. Preanalyze_Actuals (N); @@ -4860,8 +4858,6 @@ package body Sem_Ch12 is Generic_Renamings_HTable.Reset; end if; - Style_Check := Save_Style_Check; - <<Leave>> if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Act_Decl_Id); @@ -4876,8 +4872,6 @@ package body Sem_Ch12 is if Env_Installed then Restore_Env; end if; - - Style_Check := Save_Style_Check; end Analyze_Subprogram_Instantiation; ------------------------- @@ -7767,6 +7761,9 @@ package body Sem_Ch12 is Item : Node_Id; New_I : Node_Id; + Clause : Node_Id; + OK : Boolean; + begin if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then @@ -7788,17 +7785,30 @@ package body Sem_Ch12 is while Present (Item) loop if Nkind (Item) = N_With_Clause then - -- Take care to prevent direct cyclic with's, which can happen - -- if the generic body with's the current unit. Such a case - -- would result in binder errors (or run-time errors if the - -- -gnatE switch is in effect), but we want to prevent it here, - -- because Sem.Walk_Library_Items doesn't like cycles. Note - -- that we don't bother to detect indirect cycles. + -- Take care to prevent direct cyclic with's. if Library_Unit (Item) /= Current_Unit then - New_I := New_Copy (Item); - Set_Implicit_With (New_I, True); - Append (New_I, Current_Context); + -- Do not add a unit if it is already in the context + + Clause := First (Current_Context); + OK := True; + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause and then + Chars (Name (Clause)) = Chars (Name (Item)) + then + OK := False; + exit; + end if; + + Next (Clause); + end loop; + + if OK then + New_I := New_Copy (Item); + Set_Implicit_With (New_I, True); + Set_Implicit_With_From_Instantiation (New_I, True); + Append (New_I, Current_Context); + end if; end if; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d56da36f3fa..55238e2ca11 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -47,7 +47,6 @@ with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; -with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Dim; use Sem_Dim; @@ -3403,101 +3402,38 @@ package body Sem_Ch4 is ----------------------------------- procedure Analyze_Quantified_Expression (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Ent : constant Entity_Id := - New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); - - Need_Preanalysis : constant Boolean := - Operating_Mode /= Check_Semantics - and then not Alfa_Mode; - - Iterator : Node_Id; - Original_N : Node_Id; + QE_Scop : Entity_Id; begin - -- The approach in this procedure is very non-standard and at the - -- very least, extensive comments are required saying why this very - -- non-standard approach is needed??? - - -- Also general comments are needed in any case saying what is going - -- on here, since tree rewriting of this kind should normally be done - -- by the expander and not by the analyzer ??? Probably Ent, Iterator, - -- and Original_N, and Needs_Preanalysis, all need comments above ??? - - -- Preserve the original node used for the expansion of the quantified - -- expression. - - -- This is a very unusual use of Copy_Separate_Tree, needs looking at??? - - if Need_Preanalysis then - Original_N := Copy_Separate_Tree (N); - end if; - - Set_Etype (Ent, Standard_Void_Type); - Set_Scope (Ent, Current_Scope); - Set_Parent (Ent, N); - Check_SPARK_Restriction ("quantified expression is not allowed", N); - -- The following seems like expansion activity done at analysis - -- time, which seems weird ??? + -- Create a scope to emulate the loop-like behavior of the quantified + -- expression. The scope is needed to provide proper visibility of the + -- loop variable. - if Present (Loop_Parameter_Specification (N)) then - Iterator := - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Loop_Parameter_Specification (N)); - else - Iterator := - Make_Iteration_Scheme (Loc, - Iterator_Specification => - Iterator_Specification (N)); - end if; + QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); + Set_Etype (QE_Scop, Standard_Void_Type); + Set_Scope (QE_Scop, Current_Scope); + Set_Parent (QE_Scop, N); - Push_Scope (Ent); - Set_Parent (Iterator, N); - Analyze_Iteration_Scheme (Iterator); + Push_Scope (QE_Scop); - -- The loop specification may have been converted into an iterator - -- specification during its analysis. Update the quantified node - -- accordingly. + -- All constituents are preanalyzed and resolved to avoid untimely + -- generation of various temporaries and types. Full analysis and + -- expansion is carried out when the quantified expression is + -- transformed into an expression with actions. - if Present (Iterator_Specification (Iterator)) then - Set_Iterator_Specification - (N, Iterator_Specification (Iterator)); - Set_Loop_Parameter_Specification (N, Empty); - Set_Parent (Iterator_Specification (Iterator), Iterator); - end if; - - if Need_Preanalysis then - - -- The full analysis will be performed during the expansion of the - -- quantified expression, only a preanalysis of the condition needs - -- to be done. - - -- This is strange for two reasons - - -- First, there is almost no situation in which Preanalyze vs - -- Analyze should be conditioned on -gnatc mode (since error msgs - -- must be 100% unaffected by -gnatc). Seconed doing a Preanalyze - -- with no resolution almost certainly means that some messages are - -- either missed, or flagged differently in the two cases. - - Preanalyze (Condition (N)); + if Present (Iterator_Specification (N)) then + Preanalyze (Iterator_Specification (N)); else - Analyze (Condition (N)); + Preanalyze (Loop_Parameter_Specification (N)); end if; + Preanalyze_And_Resolve (Condition (N), Standard_Boolean); + End_Scope; Set_Etype (N, Standard_Boolean); - - -- Attach the original node to the iteration scheme created above - - if Need_Preanalysis then - Set_Etype (Original_N, Standard_Boolean); - Set_Parent (Iterator, Original_N); - end if; end Analyze_Quantified_Expression; ------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 834d2f1b143..6feb84cdefa 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -76,7 +76,7 @@ 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); + procedure Preanalyze_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 @@ -1607,615 +1607,32 @@ package body Sem_Ch5 is ------------------------------ procedure Analyze_Iteration_Scheme (N : Node_Id) is - - procedure Process_Bounds (R : Node_Id); - -- If the iteration is given by a range, create temporaries and - -- assignment statements block to capture the bounds and perform - -- required finalization actions in case a bound includes a function - -- call that uses the temporary stack. We first pre-analyze a copy of - -- the range in order to determine the expected type, and analyze and - -- resolve the original bounds. - - procedure Check_Controlled_Array_Attribute (DS : Node_Id); - -- If the bounds are given by a 'Range reference on a function call - -- that returns a controlled array, introduce an explicit declaration - -- to capture the bounds, so that the function result can be finalized - -- in timely fashion. - - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; - -- N is the node for an arbitrary construct. This function searches the - -- construct N to see if any expressions within it contain function - -- calls that use the secondary stack, returning True if any such call - -- is found, and False otherwise. - - -------------------- - -- Process_Bounds -- - -------------------- - - procedure Process_Bounds (R : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - R_Copy : constant Node_Id := New_Copy_Tree (R); - Lo : constant Node_Id := Low_Bound (R); - Hi : constant Node_Id := High_Bound (R); - New_Lo_Bound : Node_Id; - New_Hi_Bound : Node_Id; - Typ : Entity_Id; - - function One_Bound - (Original_Bound : Node_Id; - Analyzed_Bound : Node_Id) return Node_Id; - -- Capture value of bound and return captured value - - --------------- - -- One_Bound -- - --------------- - - function One_Bound - (Original_Bound : Node_Id; - Analyzed_Bound : Node_Id) return Node_Id - is - Assign : Node_Id; - Decl : Node_Id; - Id : Entity_Id; - - begin - -- If the bound is a constant or an object, no need for a separate - -- declaration. If the bound is the result of previous expansion - -- it is already analyzed and should not be modified. Note that - -- the Bound will be resolved later, if needed, as part of the - -- call to Make_Index (literal bounds may need to be resolved to - -- type Integer). - - if Analyzed (Original_Bound) then - return Original_Bound; - - elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, - N_Character_Literal) - or else Is_Entity_Name (Analyzed_Bound) - then - Analyze_And_Resolve (Original_Bound, Typ); - return Original_Bound; - end if; - - -- Normally, the best approach is simply to generate a constant - -- declaration that captures the bound. However, there is a nasty - -- case where this is wrong. If the bound is complex, and has a - -- possible use of the secondary stack, we need to generate a - -- separate assignment statement to ensure the creation of a block - -- which will release the secondary stack. - - -- We prefer the constant declaration, since it leaves us with a - -- proper trace of the value, useful in optimizations that get rid - -- of junk range checks. - - if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then - Analyze_And_Resolve (Original_Bound, Typ); - Force_Evaluation (Original_Bound); - return Original_Bound; - end if; - - Id := Make_Temporary (Loc, 'R', Original_Bound); - - -- Here we make a declaration with a separate assignment - -- statement, and insert before loop header. - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Id, - Object_Definition => New_Occurrence_Of (Typ, Loc)); - - Assign := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Id, Loc), - Expression => Relocate_Node (Original_Bound)); - - Insert_Actions (Parent (N), New_List (Decl, Assign)); - - -- Now that this temporary variable is initialized we decorate it - -- as safe-to-reevaluate to inform to the backend that no further - -- asignment will be issued and hence it can be handled as side - -- effect free. Note that this decoration must be done when the - -- assignment has been analyzed because otherwise it will be - -- rejected (see Analyze_Assignment). - - Set_Is_Safe_To_Reevaluate (Id); - - Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); - - if Nkind (Assign) = N_Assignment_Statement then - return Expression (Assign); - else - return Original_Bound; - end if; - end One_Bound; - - -- Start of processing for Process_Bounds - - begin - Set_Parent (R_Copy, Parent (R)); - Pre_Analyze_Range (R_Copy); - Typ := Etype (R_Copy); - - -- If the type of the discrete range is Universal_Integer, then the - -- bound's type must be resolved to Integer, and any object used to - -- hold the bound must also have type Integer, unless the literal - -- bounds are constant-folded expressions with a user-defined type. - - if Typ = Universal_Integer then - if Nkind (Lo) = N_Integer_Literal - and then Present (Etype (Lo)) - and then Scope (Etype (Lo)) /= Standard_Standard - then - Typ := Etype (Lo); - - elsif Nkind (Hi) = N_Integer_Literal - and then Present (Etype (Hi)) - and then Scope (Etype (Hi)) /= Standard_Standard - then - Typ := Etype (Hi); - - else - Typ := Standard_Integer; - end if; - end if; - - Set_Etype (R, Typ); - - New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy)); - New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy)); - - -- Propagate staticness to loop range itself, in case the - -- corresponding subtype is static. - - if New_Lo_Bound /= Lo - and then Is_Static_Expression (New_Lo_Bound) - then - Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); - end if; - - if New_Hi_Bound /= Hi - and then Is_Static_Expression (New_Hi_Bound) - then - Rewrite (High_Bound (R), New_Copy (New_Hi_Bound)); - end if; - end Process_Bounds; - - -------------------------------------- - -- Check_Controlled_Array_Attribute -- - -------------------------------------- - - procedure Check_Controlled_Array_Attribute (DS : Node_Id) is - begin - if Nkind (DS) = N_Attribute_Reference - and then Is_Entity_Name (Prefix (DS)) - and then Ekind (Entity (Prefix (DS))) = E_Function - and then Is_Array_Type (Etype (Entity (Prefix (DS)))) - and then - Is_Controlled ( - Component_Type (Etype (Entity (Prefix (DS))))) - and then Expander_Active - then - declare - Loc : constant Source_Ptr := Sloc (N); - Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); - Indx : constant Entity_Id := - Base_Type (Etype (First_Index (Arr))); - Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); - Decl : Node_Id; - - begin - Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Subt, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To (Indx, Loc), - Constraint => - Make_Range_Constraint (Loc, - Relocate_Node (DS)))); - Insert_Before (Parent (N), Decl); - Analyze (Decl); - - Rewrite (DS, - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Subt, Loc), - Attribute_Name => Attribute_Name (DS))); - Analyze (DS); - end; - end if; - end Check_Controlled_Array_Attribute; - - ------------------------------------ - -- Has_Call_Using_Secondary_Stack -- - ------------------------------------ - - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is - - function Check_Call (N : Node_Id) return Traverse_Result; - -- Check if N is a function call which uses the secondary stack - - ---------------- - -- Check_Call -- - ---------------- - - function Check_Call (N : Node_Id) return Traverse_Result is - Nam : Node_Id; - Subp : Entity_Id; - Return_Typ : Entity_Id; - - begin - if Nkind (N) = N_Function_Call then - Nam := Name (N); - - -- Call using access to subprogram with explicit dereference - - if Nkind (Nam) = N_Explicit_Dereference then - Subp := Etype (Nam); - - -- Call using a selected component notation or Ada 2005 object - -- operation notation - - elsif Nkind (Nam) = N_Selected_Component then - Subp := Entity (Selector_Name (Nam)); - - -- Common case - - else - Subp := Entity (Nam); - end if; - - Return_Typ := Etype (Subp); - - if Is_Composite_Type (Return_Typ) - and then not Is_Constrained (Return_Typ) - then - return Abandon; - - elsif Sec_Stack_Needed_For_Return (Subp) then - return Abandon; - end if; - end if; - - -- Continue traversing the tree - - return OK; - end Check_Call; - - function Check_Calls is new Traverse_Func (Check_Call); - - -- Start of processing for Has_Call_Using_Secondary_Stack - - begin - return Check_Calls (N) = Abandon; - end Has_Call_Using_Secondary_Stack; - - -- Start of processing for Analyze_Iteration_Scheme + Cond : Node_Id; + Iter_Spec : Node_Id; + Loop_Spec : Node_Id; begin - -- If this is a rewritten quantified expression, the iteration scheme - -- has been analyzed already. Do no repeat analysis because the loop - -- variable is already declared. - - if Analyzed (N) then - return; - end if; - -- For an infinite loop, there is no iteration scheme if No (N) then return; end if; - -- Iteration scheme is present + Cond := Condition (N); + Iter_Spec := Iterator_Specification (N); + Loop_Spec := Loop_Parameter_Specification (N); - declare - Cond : constant Node_Id := Condition (N); - - begin - -- For WHILE loop, verify that the condition is a Boolean expression - -- and resolve and check it. - - if Present (Cond) then - Analyze_And_Resolve (Cond, Any_Boolean); - Check_Unset_Reference (Cond); - Set_Current_Value_Condition (N); - return; - - -- For an iterator specification with "of", pre-analyze range to - -- capture function calls that may require finalization actions. - - elsif Present (Iterator_Specification (N)) then - Pre_Analyze_Range (Name (Iterator_Specification (N))); - Analyze_Iterator_Specification (Iterator_Specification (N)); - - -- Else we have a FOR loop - - else - declare - LP : constant Node_Id := Loop_Parameter_Specification (N); - Id : constant Entity_Id := Defining_Identifier (LP); - DS : constant Node_Id := Discrete_Subtype_Definition (LP); - - D_Copy : Node_Id; - - begin - Enter_Name (Id); - - -- We always consider the loop variable to be referenced, since - -- the loop may be used just for counting purposes. - - Generate_Reference (Id, N, ' '); - - -- Check for the case of loop variable hiding a local variable - -- (used later on to give a nice warning if the hidden variable - -- is never assigned). - - declare - H : constant Entity_Id := Homonym (Id); - begin - if Present (H) - and then Enclosing_Dynamic_Scope (H) = - Enclosing_Dynamic_Scope (Id) - and then Ekind (H) = E_Variable - and then Is_Discrete_Type (Etype (H)) - then - Set_Hiding_Loop_Variable (H, Id); - end if; - end; - - -- Loop parameter specification must include subtype mark in - -- SPARK. - - if Nkind (DS) = N_Range then - Check_SPARK_Restriction - ("loop parameter specification must include subtype mark", - N); - end if; - - -- Now analyze the subtype definition. If it is a range, create - -- temporaries for bounds. - - if Nkind (DS) = N_Range - and then Expander_Active - then - Process_Bounds (DS); - - -- 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. - - else - D_Copy := New_Copy_Tree (DS); - Set_Parent (D_Copy, Parent (DS)); - Pre_Analyze_Range (D_Copy); - - -- Ada 2012: If the domain of iteration is a function call, - -- it is the new iterator form. - - -- We have also implemented the shorter form : for X in S - -- for Alfa use. In this case, 'Old and 'Result must be - -- treated as entity names over which iterators are legal. - - if Nkind (D_Copy) = N_Function_Call - or else - (Alfa_Mode - and then (Nkind (D_Copy) = N_Attribute_Reference - and then - (Attribute_Name (D_Copy) = Name_Result - or else Attribute_Name (D_Copy) = Name_Old))) - or else - (Is_Entity_Name (D_Copy) - and then not Is_Type (Entity (D_Copy))) - then - -- This is an iterator specification. Rewrite as such - -- and analyze, to capture function calls that may - -- require finalization actions. - - declare - I_Spec : constant Node_Id := - Make_Iterator_Specification (Sloc (LP), - Defining_Identifier => - Relocate_Node (Id), - Name => D_Copy, - Subtype_Indication => Empty, - Reverse_Present => - Reverse_Present (LP)); - begin - Set_Iterator_Specification (N, I_Spec); - Set_Loop_Parameter_Specification (N, Empty); - Analyze_Iterator_Specification (I_Spec); - - -- In a generic context, analyze the original domain - -- of iteration, for name capture. - - if not Expander_Active then - Analyze (DS); - end if; - - -- Set kind of loop parameter, which may be used in - -- the subsequent analysis of the condition in a - -- quantified expression. - - Set_Ekind (Id, E_Loop_Parameter); - return; - end; - - -- Domain of iteration is not a function call, and is - -- side-effect free. - - else - Analyze (DS); - end if; - end if; - - if DS = Error then - return; - end if; - - -- Some additional checks if we are iterating through a type - - if Is_Entity_Name (DS) - and then Present (Entity (DS)) - and then Is_Type (Entity (DS)) - then - -- The subtype indication may denote the completion of an - -- incomplete type declaration. - - if Ekind (Entity (DS)) = E_Incomplete_Type then - Set_Entity (DS, Get_Full_View (Entity (DS))); - Set_Etype (DS, Entity (DS)); - end if; - - -- Attempt to iterate through non-static predicate - - if Is_Discrete_Type (Entity (DS)) - and then Present (Predicate_Function (Entity (DS))) - and then No (Static_Predicate (Entity (DS))) - then - Bad_Predicated_Subtype_Use - ("cannot use subtype& with non-static " - & "predicate for loop iteration", DS, Entity (DS)); - end if; - end if; - - -- Error if not discrete type - - if not Is_Discrete_Type (Etype (DS)) then - Wrong_Type (DS, Any_Discrete); - Set_Etype (DS, Any_Type); - end if; - - Check_Controlled_Array_Attribute (DS); - - -- The index is not processed during analysis of a quantified - -- expression but delayed to its expansion where the quantified - -- expression is transformed into an expression with actions. - - if Nkind (Parent (N)) /= N_Quantified_Expression - or else Operating_Mode = Check_Semantics - or else Alfa_Mode - then - Make_Index (DS, LP, In_Iter_Schm => True); - end if; - - Set_Ekind (Id, E_Loop_Parameter); - - -- If the loop is part of a predicate or precondition, it may - -- be analyzed twice, once in the source and once on the copy - -- used to check conformance. Preserve the original itype - -- because the second one may be created in a different scope, - -- e.g. a precondition procedure, leading to a crash in GIGI. - - if No (Etype (Id)) or else Etype (Id) = Any_Type then - Set_Etype (Id, Etype (DS)); - end if; - - -- Treat a range as an implicit reference to the type, to - -- inhibit spurious warnings. - - Generate_Reference (Base_Type (Etype (DS)), N, ' '); - Set_Is_Known_Valid (Id, True); - - -- The loop is not a declarative part, so the only entity - -- declared "within" must be frozen explicitly. - - declare - Flist : constant List_Id := Freeze_Entity (Id, N); - begin - if Is_Non_Empty_List (Flist) then - Insert_Actions (N, Flist); - end if; - end; - - -- Check for null or possibly null range and issue warning. We - -- suppress such messages in generic templates and instances, - -- because in practice they tend to be dubious in these cases. - - if Nkind (DS) = N_Range and then Comes_From_Source (N) then - declare - L : constant Node_Id := Low_Bound (DS); - H : constant Node_Id := High_Bound (DS); - - begin - -- If range of loop is null, issue warning - - if Compile_Time_Compare - (L, H, Assume_Valid => True) = GT - then - -- Suppress the warning if inside a generic template - -- or instance, since in practice they tend to be - -- dubious in these cases since they can result from - -- intended parametrization. - - if not Inside_A_Generic - and then not In_Instance - then - -- Specialize msg if invalid values could make the - -- loop non-null after all. - - if Compile_Time_Compare - (L, H, Assume_Valid => False) = GT - then - Error_Msg_N - ("?loop range is null, loop will not execute", - DS); - - -- Since we know the range of the loop is null, - -- set the appropriate flag to remove the loop - -- entirely during expansion. - - Set_Is_Null_Loop (Parent (N)); - - -- Here is where the loop could execute because - -- of invalid values, so issue appropriate - -- message and in this case we do not set the - -- Is_Null_Loop flag since the loop may execute. - - else - Error_Msg_N - ("?loop range may be null, " - & "loop may not execute", - DS); - Error_Msg_N - ("?can only execute if invalid values " - & "are present", - DS); - end if; - end if; - - -- In either case, suppress warnings in the body of - -- the loop, since it is likely that these warnings - -- will be inappropriate if the loop never actually - -- executes, which is likely. - - Set_Suppress_Loop_Warnings (Parent (N)); - - -- The other case for a warning is a reverse loop - -- where the upper bound is the integer literal zero - -- or one, and the lower bound can be positive. - - -- For example, we have - - -- for J in reverse N .. 1 loop + if Present (Cond) then + Analyze_And_Resolve (Cond, Any_Boolean); + Check_Unset_Reference (Cond); + Set_Current_Value_Condition (N); - -- In practice, this is very likely to be a case of - -- reversing the bounds incorrectly in the range. + elsif Present (Iter_Spec) then + Analyze_Iterator_Specification (Iter_Spec); - elsif Reverse_Present (LP) - and then Nkind (Original_Node (H)) = - N_Integer_Literal - and then (Intval (Original_Node (H)) = Uint_0 - or else - Intval (Original_Node (H)) = Uint_1) - then - Error_Msg_N ("?loop range may be null", DS); - Error_Msg_N ("\?bounds may be wrong way round", DS); - end if; - end; - end if; - end; - end if; - end; + else + Analyze_Loop_Parameter_Specification (Loop_Spec); + end if; end Analyze_Iteration_Scheme; ------------------------------------ @@ -2233,22 +1650,25 @@ package body Sem_Ch5 is begin Enter_Name (Def_Id); - Set_Ekind (Def_Id, E_Variable); if Present (Subt) then Analyze (Subt); end if; - -- If domain of iteration is an expression, create a declaration for + Preanalyze_Range (Iter_Name); + + -- If the domain of iteration is an expression, create a declaration for -- it, so that finalization actions are introduced outside of the loop. -- The declaration must be a renaming because the body of the loop may - -- assign to elements. In case of a quantified expression, this - -- declaration is delayed to its expansion where the node is rewritten - -- as an expression with actions. + -- assign to elements. When the context is a quantified expression, the + -- renaming declaration is delayed until the expansion phase. if not Is_Entity_Name (Iter_Name) - and then (Nkind (Parent (Parent (N))) /= N_Quantified_Expression + and then (Nkind (Parent (N)) /= N_Quantified_Expression + + -- The following two tests need comments ??? + or else Operating_Mode = Check_Semantics or else Alfa_Mode) then @@ -2442,6 +1862,571 @@ package body Sem_Ch5 is Set_Reachable (E, True); end Analyze_Label_Entity; + ------------------------------------------ + -- Analyze_Loop_Parameter_Specification -- + ------------------------------------------ + + procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is + Loop_Nod : constant Node_Id := Parent (Parent (N)); + + procedure Check_Controlled_Array_Attribute (DS : Node_Id); + -- If the bounds are given by a 'Range reference on a function call + -- that returns a controlled array, introduce an explicit declaration + -- to capture the bounds, so that the function result can be finalized + -- in timely fashion. + + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; + -- N is the node for an arbitrary construct. This function searches the + -- construct N to see if any expressions within it contain function + -- calls that use the secondary stack, returning True if any such call + -- is found, and False otherwise. + + procedure Process_Bounds (R : Node_Id); + -- If the iteration is given by a range, create temporaries and + -- assignment statements block to capture the bounds and perform + -- required finalization actions in case a bound includes a function + -- call that uses the temporary stack. We first pre-analyze a copy of + -- the range in order to determine the expected type, and analyze and + -- resolve the original bounds. + + -------------------------------------- + -- Check_Controlled_Array_Attribute -- + -------------------------------------- + + procedure Check_Controlled_Array_Attribute (DS : Node_Id) is + begin + if Nkind (DS) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (DS)) + and then Ekind (Entity (Prefix (DS))) = E_Function + and then Is_Array_Type (Etype (Entity (Prefix (DS)))) + and then + Is_Controlled (Component_Type (Etype (Entity (Prefix (DS))))) + and then Expander_Active + then + declare + Loc : constant Source_Ptr := Sloc (N); + Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); + Indx : constant Entity_Id := + Base_Type (Etype (First_Index (Arr))); + Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); + Decl : Node_Id; + + begin + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Indx, Loc), + Constraint => + Make_Range_Constraint (Loc, Relocate_Node (DS)))); + Insert_Before (Loop_Nod, Decl); + Analyze (Decl); + + Rewrite (DS, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Subt, Loc), + Attribute_Name => Attribute_Name (DS))); + + Analyze (DS); + end; + end if; + end Check_Controlled_Array_Attribute; + + ------------------------------------ + -- Has_Call_Using_Secondary_Stack -- + ------------------------------------ + + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is + + function Check_Call (N : Node_Id) return Traverse_Result; + -- Check if N is a function call which uses the secondary stack + + ---------------- + -- Check_Call -- + ---------------- + + function Check_Call (N : Node_Id) return Traverse_Result is + Nam : Node_Id; + Subp : Entity_Id; + Return_Typ : Entity_Id; + + begin + if Nkind (N) = N_Function_Call then + Nam := Name (N); + + -- Call using access to subprogram with explicit dereference + + if Nkind (Nam) = N_Explicit_Dereference then + Subp := Etype (Nam); + + -- Call using a selected component notation or Ada 2005 object + -- operation notation + + elsif Nkind (Nam) = N_Selected_Component then + Subp := Entity (Selector_Name (Nam)); + + -- Common case + + else + Subp := Entity (Nam); + end if; + + Return_Typ := Etype (Subp); + + if Is_Composite_Type (Return_Typ) + and then not Is_Constrained (Return_Typ) + then + return Abandon; + + elsif Sec_Stack_Needed_For_Return (Subp) then + return Abandon; + end if; + end if; + + -- Continue traversing the tree + + return OK; + end Check_Call; + + function Check_Calls is new Traverse_Func (Check_Call); + + -- Start of processing for Has_Call_Using_Secondary_Stack + + begin + return Check_Calls (N) = Abandon; + end Has_Call_Using_Secondary_Stack; + + -------------------- + -- Process_Bounds -- + -------------------- + + procedure Process_Bounds (R : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Capture value of bound and return captured value + + --------------- + -- One_Bound -- + --------------- + + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id; + Typ : Entity_Id) return Node_Id + is + Assign : Node_Id; + Decl : Node_Id; + Id : Entity_Id; + + begin + -- If the bound is a constant or an object, no need for a separate + -- declaration. If the bound is the result of previous expansion + -- it is already analyzed and should not be modified. Note that + -- the Bound will be resolved later, if needed, as part of the + -- call to Make_Index (literal bounds may need to be resolved to + -- type Integer). + + if Analyzed (Original_Bound) then + return Original_Bound; + + elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, + N_Character_Literal) + or else Is_Entity_Name (Analyzed_Bound) + then + Analyze_And_Resolve (Original_Bound, Typ); + return Original_Bound; + end if; + + -- Normally, the best approach is simply to generate a constant + -- declaration that captures the bound. However, there is a nasty + -- case where this is wrong. If the bound is complex, and has a + -- possible use of the secondary stack, we need to generate a + -- separate assignment statement to ensure the creation of a block + -- which will release the secondary stack. + + -- We prefer the constant declaration, since it leaves us with a + -- proper trace of the value, useful in optimizations that get rid + -- of junk range checks. + + if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then + Analyze_And_Resolve (Original_Bound, Typ); + Force_Evaluation (Original_Bound); + return Original_Bound; + end if; + + Id := Make_Temporary (Loc, 'R', Original_Bound); + + -- Here we make a declaration with a separate assignment + -- statement, and insert before loop header. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Id, Loc), + Expression => Relocate_Node (Original_Bound)); + + Insert_Actions (Loop_Nod, New_List (Decl, Assign)); + + -- Now that this temporary variable is initialized we decorate it + -- as safe-to-reevaluate to inform to the backend that no further + -- asignment will be issued and hence it can be handled as side + -- effect free. Note that this decoration must be done when the + -- assignment has been analyzed because otherwise it will be + -- rejected (see Analyze_Assignment). + + Set_Is_Safe_To_Reevaluate (Id); + + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); + + if Nkind (Assign) = N_Assignment_Statement then + return Expression (Assign); + else + return Original_Bound; + end if; + end One_Bound; + + Hi : constant Node_Id := High_Bound (R); + Lo : constant Node_Id := Low_Bound (R); + R_Copy : constant Node_Id := New_Copy_Tree (R); + New_Hi : Node_Id; + New_Lo : Node_Id; + Typ : Entity_Id; + + -- Start of processing for Process_Bounds + + begin + Set_Parent (R_Copy, Parent (R)); + Preanalyze_Range (R_Copy); + Typ := Etype (R_Copy); + + -- If the type of the discrete range is Universal_Integer, then the + -- bound's type must be resolved to Integer, and any object used to + -- hold the bound must also have type Integer, unless the literal + -- bounds are constant-folded expressions with a user-defined type. + + if Typ = Universal_Integer then + if Nkind (Lo) = N_Integer_Literal + and then Present (Etype (Lo)) + and then Scope (Etype (Lo)) /= Standard_Standard + then + Typ := Etype (Lo); + + elsif Nkind (Hi) = N_Integer_Literal + and then Present (Etype (Hi)) + and then Scope (Etype (Hi)) /= Standard_Standard + then + Typ := Etype (Hi); + + else + Typ := Standard_Integer; + end if; + end if; + + Set_Etype (R, Typ); + + New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ); + New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ); + + -- Propagate staticness to loop range itself, in case the + -- corresponding subtype is static. + + if New_Lo /= Lo + and then Is_Static_Expression (New_Lo) + then + Rewrite (Low_Bound (R), New_Copy (New_Lo)); + end if; + + if New_Hi /= Hi + and then Is_Static_Expression (New_Hi) + then + Rewrite (High_Bound (R), New_Copy (New_Hi)); + end if; + end Process_Bounds; + + -- Local variables + + DS : constant Node_Id := Discrete_Subtype_Definition (N); + Id : constant Entity_Id := Defining_Identifier (N); + + DS_Copy : Node_Id; + + -- Start of processing for Analyze_Loop_Parameter_Specification + + begin + Enter_Name (Id); + + -- We always consider the loop variable to be referenced, since the loop + -- may be used just for counting purposes. + + Generate_Reference (Id, N, ' '); + + -- Check for the case of loop variable hiding a local variable (used + -- later on to give a nice warning if the hidden variable is never + -- assigned). + + declare + H : constant Entity_Id := Homonym (Id); + begin + if Present (H) + and then Ekind (H) = E_Variable + and then Is_Discrete_Type (Etype (H)) + and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id) + then + Set_Hiding_Loop_Variable (H, Id); + end if; + end; + + -- Loop parameter specification must include subtype mark in SPARK + + if Nkind (DS) = N_Range then + Check_SPARK_Restriction + ("loop parameter specification must include subtype mark", N); + end if; + + -- Analyze the subtype definition and create temporaries for the bounds. + -- Do not evaluate the range when preanalyzing a quantified expression + -- because bounds expressed as function calls with side effects will be + -- erroneously replicated. + + if Nkind (DS) = N_Range + and then Expander_Active + and then Nkind (Parent (N)) /= N_Quantified_Expression + then + Process_Bounds (DS); + + -- Either the expander not active or the range of iteration is a subtype + -- indication, an entity, or a function call that yields an aggregate or + -- a container. + + else + DS_Copy := New_Copy_Tree (DS); + Set_Parent (DS_Copy, Parent (DS)); + Preanalyze_Range (DS_Copy); + + -- Ada 2012: If the domain of iteration is a function call, it is the + -- new iterator form. + + -- We have also implemented the shorter form : for X in S for Alfa + -- use. In this case, 'Old and 'Result must be treated as entity + -- names over which iterators are legal. + + if Nkind (DS_Copy) = N_Function_Call + or else + (Alfa_Mode + and then (Nkind (DS_Copy) = N_Attribute_Reference + and then + (Attribute_Name (DS_Copy) = Name_Result + or else Attribute_Name (DS_Copy) = Name_Old))) + or else + (Is_Entity_Name (DS_Copy) + and then not Is_Type (Entity (DS_Copy))) + then + -- This is an iterator specification. Rewrite it as such and + -- analyze it to capture function calls that may require + -- finalization actions. + + declare + I_Spec : constant Node_Id := + Make_Iterator_Specification (Sloc (N), + Defining_Identifier => Relocate_Node (Id), + Name => DS_Copy, + Subtype_Indication => Empty, + Reverse_Present => Reverse_Present (N)); + Scheme : constant Node_Id := Parent (N); + + begin + Set_Iterator_Specification (Scheme, I_Spec); + Set_Loop_Parameter_Specification (Scheme, Empty); + Analyze_Iterator_Specification (I_Spec); + + -- In a generic context, analyze the original domain of + -- iteration, for name capture. + + if not Expander_Active then + Analyze (DS); + end if; + + -- Set kind of loop parameter, which may be used in the + -- subsequent analysis of the condition in a quantified + -- expression. + + Set_Ekind (Id, E_Loop_Parameter); + return; + end; + + -- Domain of iteration is not a function call, and is side-effect + -- free. + + else + Analyze (DS); + end if; + end if; + + if DS = Error then + return; + end if; + + -- Some additional checks if we are iterating through a type + + if Is_Entity_Name (DS) + and then Present (Entity (DS)) + and then Is_Type (Entity (DS)) + then + -- The subtype indication may denote the completion of an incomplete + -- type declaration. + + if Ekind (Entity (DS)) = E_Incomplete_Type then + Set_Entity (DS, Get_Full_View (Entity (DS))); + Set_Etype (DS, Entity (DS)); + end if; + + -- Attempt to iterate through non-static predicate + + if Is_Discrete_Type (Entity (DS)) + and then Present (Predicate_Function (Entity (DS))) + and then No (Static_Predicate (Entity (DS))) + then + Bad_Predicated_Subtype_Use + ("cannot use subtype& with non-static predicate for loop " & + "iteration", DS, Entity (DS)); + end if; + end if; + + -- Error if not discrete type + + if not Is_Discrete_Type (Etype (DS)) then + Wrong_Type (DS, Any_Discrete); + Set_Etype (DS, Any_Type); + end if; + + Check_Controlled_Array_Attribute (DS); + + Make_Index (DS, N, In_Iter_Schm => True); + Set_Ekind (Id, E_Loop_Parameter); + + -- A quantified expression which appears in a pre- or post-condition may + -- be analyzed multiple times. The analysis of the range creates several + -- itypes which reside in different scopes depending on whether the pre- + -- or post-condition has been expanded. Update the type of the loop + -- variable to reflect the proper itype at each stage of analysis. + + if No (Etype (Id)) + or else Etype (Id) = Any_Type + or else + (Present (Etype (Id)) + and then Is_Itype (Etype (Id)) + and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions + and then Nkind (Original_Node (Parent (Loop_Nod))) = + N_Quantified_Expression) + then + Set_Etype (Id, Etype (DS)); + end if; + + -- Treat a range as an implicit reference to the type, to inhibit + -- spurious warnings. + + Generate_Reference (Base_Type (Etype (DS)), N, ' '); + Set_Is_Known_Valid (Id, True); + + -- The loop is not a declarative part, so the only entity declared + -- "within" must be frozen explicitly. + + declare + Flist : constant List_Id := Freeze_Entity (Id, N); + begin + if Is_Non_Empty_List (Flist) then + Insert_Actions (N, Flist); + end if; + end; + + -- Check for null or possibly null range and issue warning. We suppress + -- such messages in generic templates and instances, because in practice + -- they tend to be dubious in these cases. + + if Nkind (DS) = N_Range and then Comes_From_Source (N) then + declare + L : constant Node_Id := Low_Bound (DS); + H : constant Node_Id := High_Bound (DS); + + begin + -- If range of loop is null, issue warning + + if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then + + -- Suppress the warning if inside a generic template or + -- instance, since in practice they tend to be dubious in these + -- cases since they can result from intended parametrization. + + if not Inside_A_Generic + and then not In_Instance + then + -- Specialize msg if invalid values could make the loop + -- non-null after all. + + if Compile_Time_Compare + (L, H, Assume_Valid => False) = GT + then + Error_Msg_N + ("?loop range is null, loop will not execute", DS); + + -- Since we know the range of the loop is null, set the + -- appropriate flag to remove the loop entirely during + -- expansion. + + Set_Is_Null_Loop (Loop_Nod); + + -- Here is where the loop could execute because of invalid + -- values, so issue appropriate message and in this case we + -- do not set the Is_Null_Loop flag since the loop may + -- execute. + + else + Error_Msg_N + ("?loop range may be null, loop may not execute", DS); + Error_Msg_N + ("?can only execute if invalid values are present", DS); + end if; + end if; + + -- In either case, suppress warnings in the body of the loop, + -- since it is likely that these warnings will be inappropriate + -- if the loop never actually executes, which is likely. + + Set_Suppress_Loop_Warnings (Loop_Nod); + + -- The other case for a warning is a reverse loop where the + -- upper bound is the integer literal zero or one, and the + -- lower bound can be positive. + + -- For example, we have + + -- for J in reverse N .. 1 loop + + -- In practice, this is very likely to be a case of reversing + -- the bounds incorrectly in the range. + + elsif Reverse_Present (N) + and then Nkind (Original_Node (H)) = N_Integer_Literal + and then + (Intval (Original_Node (H)) = Uint_0 + or else Intval (Original_Node (H)) = Uint_1) + then + Error_Msg_N ("?loop range may be null", DS); + Error_Msg_N ("\?bounds may be wrong way round", DS); + end if; + end; + end if; + end Analyze_Loop_Parameter_Specification; + ---------------------------- -- Analyze_Loop_Statement -- ---------------------------- @@ -2482,7 +2467,7 @@ package body Sem_Ch5 is begin Nam_Copy := New_Copy_Tree (Nam); Set_Parent (Nam_Copy, Parent (Nam)); - Pre_Analyze_Range (Nam_Copy); + Preanalyze_Range (Nam_Copy); -- The only two options here are iteration over a container or -- an array. @@ -2501,7 +2486,7 @@ package body Sem_Ch5 is begin DS_Copy := New_Copy_Tree (DS); Set_Parent (DS_Copy, Parent (DS)); - Pre_Analyze_Range (DS_Copy); + Preanalyze_Range (DS_Copy); -- Check for a call to Iterate () @@ -2907,11 +2892,11 @@ package body Sem_Ch5 is end if; end Check_Unreachable_Code; - ----------------------- - -- Pre_Analyze_Range -- - ----------------------- + ---------------------- + -- Preanalyze_Range -- + ---------------------- - procedure Pre_Analyze_Range (R_Copy : Node_Id) is + procedure Preanalyze_Range (R_Copy : Node_Id) is Save_Analysis : constant Boolean := Full_Analysis; begin @@ -2977,6 +2962,6 @@ package body Sem_Ch5 is Expander_Mode_Restore; Full_Analysis := Save_Analysis; - end Pre_Analyze_Range; + end Preanalyze_Range; end Sem_Ch5; diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index fdf09db32d5..86a92b76c5e 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,19 +27,20 @@ with Types; use Types; package Sem_Ch5 is - procedure Analyze_Assignment (N : Node_Id); - procedure Analyze_Block_Statement (N : Node_Id); - procedure Analyze_Case_Statement (N : Node_Id); - procedure Analyze_Exit_Statement (N : Node_Id); - procedure Analyze_Goto_Statement (N : Node_Id); - procedure Analyze_If_Statement (N : Node_Id); - procedure Analyze_Implicit_Label_Declaration (N : Node_Id); - procedure Analyze_Iterator_Specification (N : Node_Id); - procedure Analyze_Iteration_Scheme (N : Node_Id); - procedure Analyze_Label (N : Node_Id); - procedure Analyze_Loop_Statement (N : Node_Id); - procedure Analyze_Null_Statement (N : Node_Id); - procedure Analyze_Statements (L : List_Id); + procedure Analyze_Assignment (N : Node_Id); + procedure Analyze_Block_Statement (N : Node_Id); + procedure Analyze_Case_Statement (N : Node_Id); + procedure Analyze_Exit_Statement (N : Node_Id); + procedure Analyze_Goto_Statement (N : Node_Id); + procedure Analyze_If_Statement (N : Node_Id); + procedure Analyze_Implicit_Label_Declaration (N : Node_Id); + procedure Analyze_Iterator_Specification (N : Node_Id); + procedure Analyze_Iteration_Scheme (N : Node_Id); + procedure Analyze_Label (N : Node_Id); + procedure Analyze_Loop_Parameter_Specification (N : Node_Id); + procedure Analyze_Loop_Statement (N : Node_Id); + procedure Analyze_Null_Statement (N : Node_Id); + procedure Analyze_Statements (L : List_Id); procedure Analyze_Label_Entity (E : Entity_Id); -- This procedure performs direct analysis of the label entity E. It diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8ec60c7abb3..4c7f2e47224 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8702,7 +8702,9 @@ package body Sem_Ch6 is Discrete_Subtype_Definition (L2)); end; - else -- quantified expression with an iterator + elsif Present (Iterator_Specification (E1)) + and then Present (Iterator_Specification (E2)) + then declare I1 : constant Node_Id := Iterator_Specification (E1); I2 : constant Node_Id := Iterator_Specification (E2); @@ -8719,6 +8721,12 @@ package body Sem_Ch6 is and then FCE (Subtype_Indication (I1), Subtype_Indication (I2)); end; + + -- The quantified expressions used different specifications to + -- walk their respective ranges. + + else + return False; end if; when N_Range => @@ -11057,6 +11065,9 @@ package body Sem_Ch6 is -- that an invariant check is required (for an IN OUT parameter, or -- the returned value of a function. + function Last_Implicit_Declaration return Node_Id; + -- Return the last internally-generated declaration of N + ------------- -- Grab_CC -- ------------- @@ -11307,6 +11318,50 @@ package body Sem_Ch6 is end if; end Is_Public_Subprogram_For; + ------------------------------- + -- Last_Implicit_Declaration -- + ------------------------------- + + function Last_Implicit_Declaration return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Decls : List_Id := Declarations (N); + Decl : Node_Id; + Succ : Node_Id; + + begin + if No (Decls) then + Decls := New_List (Make_Null_Statement (Loc)); + Set_Declarations (N, Decls); + + elsif Is_Empty_List (Declarations (N)) then + Append_To (Decls, Make_Null_Statement (Loc)); + end if; + + -- Implicit and source declarations may be interspersed. Search for + -- the last implicit declaration which is either succeeded by a + -- source construct or is the last node in the declarative list. + + Decl := First (Declarations (N)); + while Present (Decl) loop + Succ := Next (Decl); + + -- The current declaration is the last one, do not return Empty + + if No (Succ) then + exit; + + -- The successor is a source construct + + elsif Comes_From_Source (Succ) then + exit; + end if; + + Next (Decl); + end loop; + + return Decl; + end Last_Implicit_Declaration; + -- Start of processing for Process_PPCs begin @@ -11712,7 +11767,7 @@ package body Sem_Ch6 is -- The entity for the _Postconditions procedure begin - Prepend_To (Declarations (N), + Insert_After (Last_Implicit_Declaration, Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 46a8b194853..ef5f8b4ed50 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -193,7 +193,6 @@ package body Sem_Res is procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); @@ -1770,6 +1769,10 @@ package body Sem_Res is -- Try and fix up a literal so that it matches its expected type. New -- literals are manufactured if necessary to avoid cascaded errors. + function Proper_Current_Scope return Entity_Id; + -- Return the current scope. Skip loop scopes created for the purpose of + -- quantified expression analysis since those do not appear in the tree. + procedure Report_Ambiguous_Argument; -- Additional diagnostics when an ambiguous call has an ambiguous -- argument (typically a controlling actual). @@ -1832,6 +1835,30 @@ package body Sem_Res is end if; end Patch_Up_Value; + -------------------------- + -- Proper_Current_Scope -- + -------------------------- + + function Proper_Current_Scope return Entity_Id is + S : Entity_Id := Current_Scope; + + begin + while Present (S) loop + + -- Skip a loop scope created for quantified expression analysis + + if Ekind (S) = E_Loop + and then Nkind (Parent (S)) = N_Quantified_Expression + then + S := Scope (S); + else + exit; + end if; + end loop; + + return S; + end Proper_Current_Scope; + ------------------------------- -- Report_Ambiguous_Argument -- ------------------------------- @@ -2597,10 +2624,10 @@ package body Sem_Res is -- an error. We can't do this earlier, because it would cause legal -- cases to get errors (when some other type has an abstract "+"). - if Ada_Version >= Ada_2005 and then - Nkind (N) in N_Op and then - Is_Overloaded (N) and then - Is_Universal_Numeric_Type (Etype (Entity (N))) + if Ada_Version >= Ada_2005 + and then Nkind (N) in N_Op + and then Is_Overloaded (N) + and then Is_Universal_Numeric_Type (Etype (Entity (N))) then Get_First_Interp (N, I, It); while Present (It.Typ) loop @@ -2761,8 +2788,7 @@ package body Sem_Res is when N_Qualified_Expression => Resolve_Qualified_Expression (N, Ctx_Type); - when N_Quantified_Expression - => Resolve_Quantified_Expression (N, Ctx_Type); + when N_Quantified_Expression => null; when N_Raise_xxx_Error => Set_Etype (N, Ctx_Type); @@ -2857,10 +2883,9 @@ package body Sem_Res is -- Ada 2012 (AI05-177): Expression functions do not freeze. Only -- their use (in an expanded call) freezes. - if Ekind (Current_Scope) /= E_Function - or else - Nkind (Original_Node (Unit_Declaration_Node (Current_Scope))) /= - N_Expression_Function + if Ekind (Proper_Current_Scope) /= E_Function + or else Nkind (Original_Node (Unit_Declaration_Node + (Proper_Current_Scope))) /= N_Expression_Function then Freeze_Expression (N); end if; @@ -5316,7 +5341,18 @@ package body Sem_Res is -- needs extending because we can generate procedure calls that need -- freezing. - if Is_Entity_Name (Subp) and then not In_Spec_Expression then + -- In Ada 2012, expression functions may be called within pre/post + -- conditions of subsequent functions or expression functions. Such + -- calls do not freeze when they appear within generated bodies, which + -- would place the freeze node in the wrong scope. An expression + -- function is frozen in the usual fashion, by the appearance of a real + -- body, or at the end of a declarative part. + + if Is_Entity_Name (Subp) and then not In_Spec_Expression + and then + (not Is_Expression_Function (Entity (Subp)) + or else Scope (Entity (Subp)) = Current_Scope) + then Freeze_Expression (Subp); end if; @@ -6082,15 +6118,36 @@ package body Sem_Res is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); Else_Expr : Node_Id := Next (Then_Expr); + Else_Typ : Entity_Id; + Then_Typ : Entity_Id; begin Resolve (Condition, Any_Boolean); Resolve (Then_Expr, Typ); + Then_Typ := Etype (Then_Expr); + + -- When the "then" and "else" expressions are of a scalar type, insert + -- a conversion to ensure the generation of a constraint check. + + if Is_Scalar_Type (Then_Typ) + and then Then_Typ /= Typ + then + Rewrite (Then_Expr, Convert_To (Typ, Then_Expr)); + Analyze_And_Resolve (Then_Expr, Typ); + end if; -- If ELSE expression present, just resolve using the determined type if Present (Else_Expr) then Resolve (Else_Expr, Typ); + Else_Typ := Etype (Else_Expr); + + if Is_Scalar_Type (Else_Typ) + and then Else_Typ /= Typ + then + Rewrite (Else_Expr, Convert_To (Typ, Else_Expr)); + Analyze_And_Resolve (Else_Expr, Typ); + end if; -- If no ELSE expression is present, root type must be Standard.Boolean -- and we provide a Standard.True result converted to the appropriate @@ -8279,31 +8336,6 @@ package body Sem_Res is Eval_Qualified_Expression (N); end Resolve_Qualified_Expression; - ----------------------------------- - -- Resolve_Quantified_Expression -- - ----------------------------------- - - procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is - begin - if not Alfa_Mode then - - -- The loop structure is already resolved during its analysis, only - -- the resolution of the condition needs to be done. Expansion is - -- disabled so that checks and other generated code are inserted in - -- the tree after expression has been rewritten as a loop. - - Expander_Mode_Save_And_Set (False); - Resolve (Condition (N), Typ); - Expander_Mode_Restore; - - -- In Alfa mode, we need normal expansion in order to properly introduce - -- the necessary transient scopes. - - else - Resolve (Condition (N), Typ); - end if; - end Resolve_Quantified_Expression; - ------------------- -- Resolve_Range -- ------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6519221cbe6..b5255177b2c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -742,11 +742,25 @@ package body Sem_Util is Loc : constant Source_Ptr := Sloc (N); Disc : Entity_Id; + Bas : Entity_Id; + -- The base type that is to be constrained by the defaults + begin if not Has_Discriminants (T) or else Is_Constrained (T) then return T; end if; + Bas := Base_Type (T); + + -- If T is non-private but its base type is private, this is the + -- completion of a subtype declaration whose parent type is private + -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants + -- are to be found in the full view of the base. + + if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then + Bas := Full_View (Bas); + end if; + Disc := First_Discriminant (T); if No (Discriminant_Default_Value (Disc)) then @@ -768,10 +782,10 @@ package body Sem_Util is Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Act, - Subtype_Indication => + Subtype_Indication => Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (T, Loc), - Constraint => + Subtype_Mark => New_Occurrence_Of (Bas, Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constraints))); @@ -798,8 +812,8 @@ package body Sem_Util is -- of the prefix. function Build_Discriminal_Record_Constraint return List_Id; - -- Similar to previous one, for discriminated components constrained - -- by the discriminant of the enclosing object. + -- Similar to previous one, for discriminated components constrained by + -- the discriminant of the enclosing object. ---------------------------------------- -- Build_Discriminal_Array_Constraint -- @@ -955,12 +969,7 @@ package body Sem_Util is -- and thus will not have the unit name automatically prepended. Set_Package_Name (Spec_Id); - - -- Append _E - - Name_Buffer (Name_Len + 1) := '_'; - Name_Buffer (Name_Len + 2) := 'E'; - Name_Len := Name_Len + 2; + Add_Str_To_Name_Buffer ("_E"); -- Create elaboration counter @@ -986,9 +995,9 @@ package body Sem_Util is Set_Current_Value (Elab_Ent, Empty); Set_Last_Assignment (Elab_Ent, Empty); - -- We do not want any further qualification of the name (if we did - -- not do this, we would pick up the name of the generic package - -- in the case of a library level generic instantiation). + -- We do not want any further qualification of the name (if we did not + -- do this, we would pick up the name of the generic package in the case + -- of a library level generic instantiation). Set_Has_Qualified_Name (Elab_Ent); Set_Has_Fully_Qualified_Name (Elab_Ent); @@ -1073,8 +1082,7 @@ package body Sem_Util is then return False; else - return - Cannot_Raise_Constraint_Error (Expression (Expr)); + return Cannot_Raise_Constraint_Error (Expression (Expr)); end if; when N_Unchecked_Type_Conversion => @@ -1084,8 +1092,7 @@ package body Sem_Util is if Do_Overflow_Check (Expr) then return False; else - return - Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; when N_Op_Divide | @@ -1142,8 +1149,7 @@ package body Sem_Util is -- Check_Implicit_Dereference -- -------------------------------- - procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) - is + procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is Disc : Entity_Id; Desig : Entity_Id; @@ -8674,7 +8680,6 @@ package body Sem_Util is -- only affects the generation of internal expanded code, since -- calls to instantiations of Unchecked_Conversion are never -- considered variables (since they are function calls). - -- This is also true for expression actions. when N_Unchecked_Type_Conversion => return Is_Variable (Expression (Orig_Node)); @@ -10500,6 +10505,34 @@ package body Sem_Util is Actual_Id := Next_Actual (Actual_Id); end Next_Actual; + --------------------- + -- No_Scalar_Parts -- + --------------------- + + function No_Scalar_Parts (T : Entity_Id) return Boolean is + C : Entity_Id; + + begin + if Is_Scalar_Type (T) then + return False; + + elsif Is_Array_Type (T) then + return No_Scalar_Parts (Component_Type (T)); + + elsif Is_Record_Type (T) or else Has_Discriminants (T) then + C := First_Component_Or_Discriminant (T); + while Present (C) loop + if not No_Scalar_Parts (Etype (C)) then + return False; + else + Next_Component_Or_Discriminant (C); + end if; + end loop; + end if; + + return True; + end No_Scalar_Parts; + ----------------------- -- Normalize_Actuals -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 34d2fc0383c..607bd8e72e0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1221,6 +1221,11 @@ package Sem_Util is -- Note that the result produced is always an expression, not a parameter -- association node, even if named notation was used. + function No_Scalar_Parts (T : Entity_Id) return Boolean; + -- Tests if type T can be determined at compile time to have no scalar + -- parts in the sense of the Valid_Scalars attribute. Returns True if + -- this is the case, meaning that the result of Valid_Scalars is True. + procedure Normalize_Actuals (N : Node_Id; S : Entity_Id; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index a8388b19344..a89f9b26269 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1624,6 +1624,14 @@ package body Sinfo is return Flag16 (N); end Implicit_With; + function Implicit_With_From_Instantiation + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag12 (N); + end Implicit_With_From_Instantiation; + function Interface_List (N : Node_Id) return List_Id is begin @@ -4704,6 +4712,14 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Implicit_With; + procedure Set_Implicit_With_From_Instantiation + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag12 (N, Val); + end Set_Implicit_With_From_Instantiation; + procedure Set_Interface_List (N : Node_Id; Val : List_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0972d9c1603..fa7dbee35aa 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1226,6 +1226,9 @@ package Sinfo is -- 'Address or 'Tag attribute. ???There are other implicit with clauses -- as well. + -- Implicit_With_From_Instantiation (Flag12-Sem) + -- Set in N_With_Clause nodes from generic instantiations. + -- Import_Interface_Present (Flag16-Sem) -- This flag is set in an Interface or Import pragma if a matching -- pragma of the other kind is also present. This is used to avoid @@ -1252,7 +1255,7 @@ package Sinfo is -- to the node for the spec of the instance, inserted as part of the -- semantic processing for instantiations in Sem_Ch12. - -- Is_Accessibility_Actual (Flag12-Sem) + -- Is_Accessibility_Actual (Flag13-Sem) -- Present in N_Parameter_Association nodes. True if the parameter is -- an extra actual that carries the accessibility level of the actual -- for an access parameter, in a function that dispatches on result and @@ -5805,6 +5808,7 @@ package Sinfo is -- Elaborate_Desirable (Flag11-Sem) -- Private_Present (Flag15) set if with_clause has private keyword -- Implicit_With (Flag16-Sem) + -- Implicit_With_From_Instantiation (Flag12-Sem) -- Limited_Present (Flag17) set if LIMITED is present -- Limited_View_Installed (Flag18-Sem) -- Unreferenced_In_Spec (Flag7-Sem) @@ -8592,6 +8596,9 @@ package Sinfo is function Implicit_With (N : Node_Id) return Boolean; -- Flag16 + function Implicit_With_From_Instantiation + (N : Node_Id) return Boolean; -- Flag12 + function Import_Interface_Present (N : Node_Id) return Boolean; -- Flag16 @@ -9573,6 +9580,9 @@ package Sinfo is procedure Set_Implicit_With (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Implicit_With_From_Instantiation + (N : Node_Id; Val : Boolean := True); -- Flag12 + procedure Set_Import_Interface_Present (N : Node_Id; Val : Boolean := True); -- Flag16 @@ -11959,6 +11969,7 @@ package Sinfo is pragma Inline (High_Bound); pragma Inline (Identifier); pragma Inline (Implicit_With); + pragma Inline (Implicit_With_From_Instantiation); pragma Inline (Interface_List); pragma Inline (Interface_Present); pragma Inline (Includes_Infinities); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index ed30b9b5aac..c85fdd01d19 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1199,6 +1199,7 @@ package Snames is Name_Object_File_Switches : constant Name_Id := N + $; Name_Object_Generated : constant Name_Id := N + $; Name_Object_List : constant Name_Id := N + $; + Name_Object_Path_Switches : constant Name_Id := N + $; Name_Objects_Linked : constant Name_Id := N + $; Name_Objects_Path : constant Name_Id := N + $; Name_Objects_Path_File : constant Name_Id := N + $; diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index 727a0cdf452..b60370231b1 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -236,7 +236,13 @@ package body Style is procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is begin - if Style_Check_Missing_Overriding and then Comes_From_Source (N) then + + -- Perform the check on source subprograms and on subprogram instances, + -- because these can be primitives of untagged types. + + if Style_Check_Missing_Overriding + and then (Comes_From_Source (N) or else Is_Generic_Instance (E)) + then if Nkind (N) = N_Subprogram_Body then Error_Msg_NE -- CODEFIX ("(style) missing OVERRIDING indicator in body of&", N, E); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 789fb9b5b4d..7cb0ee06a65 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -516,6 +516,24 @@ package body Switch.C is new String'(Switch_Chars (Ptr .. Max)); return; + -- -gnateO= (object path file) + + when 'O' => + Store_Switch := False; + Ptr := Ptr + 1; + + -- Check for '=' + + if Ptr >= Max or else Switch_Chars (Ptr) /= '=' then + Bad_Switch ("-gnateO"); + + else + Object_Path_File_Name := + new String'(Switch_Chars (Ptr + 1 .. Max)); + end if; + + return; + -- -gnatep (preprocessing data file) when 'p' => |