2004-06-25 Pascal Obry <obry@gnat.com>

	* makegpr.adb (Build_Library): Remove parameter Lib_Address and
	Relocatable from Build_Dynamic_Library call.

	* gnat_ugn.texi: Change documentation about Library_Kind. Dynamic and
	Relocatable are now synonym.

	* Makefile.in: Use s-parame-mingw.adb on MingW platform.

	* mlib-prj.adb (Build_Library): Remove DLL_Address constant definition.
	Remove parameter Lib_Address and Relocatable from Build_Dynamic_Library
	call.

	* mlib-tgt.ads, mlib-tgt.adb (Build_Dynamic_Library): Remove parameter
	Lib_Address and Relocatable.
	(Default_DLL_Address): Removed.

	* mlib-tgt-tru64.adb, mlib-tgt-aix.adb, mlib-tgt-irix.adb,
	mlib-tgt-hpux.adb, mlib-tgt-linux.adb, mlib-tgt-solaris.adb,
	mlib-tgt-vms-alpha.adb, mlib-tgt-vms-ia64.adb, mlib-tgt-vxworks.adb:
	(Build_Dynamic_Library): Remove parameter Lib_Address and Relocatable.
	(Default_DLL_Address): Removed.

	* mlib-tgt-mingw.adb: Ditto.
	(Build_Dynamic_Library): Do not add "lib" prefix to the DLL name.

	* s-taprop-mingw.adb (Create_Task): Use Adjust_Storage_Size to compute
	the initial thread stack size.

	* a-strmap.ads: Move package L to private part as it is not used in
	the spec. Found while reading code.

2004-06-25  Olivier Hainque  <hainque@act-europe.fr>

	* tracebak.c: Introduce support for a GCC infrastructure based
	implementation of __gnat_backtrace.

	* raise.c: Don't rely on a C mapping of the GNAT_GCC_Exception record
	any more. Use accessors instead. This eases maintenance and relaxes
	some alignment constraints.
	(_GNAT_Exception structure): Remove the Ada specific fields
	(EID_For, Adjust_N_Cleanups_For): New accessors, exported by
	a-exexpr.adb.
	(is_handled_by, __gnat_eh_personality): Replace component references to
	exception structure by use of the new accessors.

	* init.c (__gnat_initialize): Adjust comments to match the just
	reverted meaning of the -static link-time option.

	* adaint.c (convert_addresses): Arrange not to define a stub for
	mips-irix any more, as we now want to rely on a real version from a
	recent libaddr2line.

	* a-exexpr.adb: Provide new accessors to a GNAT_GCC occurrence, so that
	the personality routine can use them and not have to rely on a C
	counterpart of the record anymore. This simplifies maintenance and
	relaxes the constraint of having Standard'Maximum_Alignment match
	BIGGEST_ALIGNMENT.
	Update comments, and add a section on the common header alignment issue.

2004-06-25  Geert Bosch  <bosch@gnat.com>

	* a-ngelfu.adb (Tanh): Use full 20 digit precision for constants in
	polynomial approximation. Fixes inconsistency with Cody/Waite algorithm.

2004-06-25  Robert Dewar  <dewar@gnat.com>

	* gnat_rm.texi: Fix section on component clauses to indicate that the
	restriction on byte boundary placement still applies for bit packed
	arrays.
	Add comment on stack usage from Initialize_Scalars

	* gnat_ugn.texi: Add documentation for -gnatyLnnn

	* stylesw.ads, stylesw.adb: Implement new -gnatyLnnn option for
	limiting nesting level.

	* usage.adb: Add line for -gnatyLnnn switch

	* g-debpoo.ads, xtreeprs.adb, sinput.ads, sem_ch13.ads,
	sem_ch13.adb, exp_aggr.adb: Minor reformatting

	* sem_prag.adb (Process_Atomic_Shared_Volatile): Set Is_Atomic on base
	type as well as on the subtype. This corrects a problem in freeze in
	setting alignments of atomic types.

	* sem_eval.ads: Minor comment typo fixed

	* par-util.adb (Push_Scope_Stack): Check for violation of max nesting
	level.  Minor reformatting.

	* fname.adb (Is_Predefined_File_Name): Require a letter after the
	minus sign. This means that file names like a--b.adb will not be
	considered predefined.

	* freeze.adb: Propagate new flag Must_Be_On_Byte_Boundary to containing
	record Test new flag and give diagnostic for bad component clause.
	(Freeze_Entity): Set alignment of array from component alignment in
	cases where this is safe to do.

	* exp_pakd.adb: Set new flag Must_Be_On_Byte_Boundary for large packed
	arrays.

	* cstand.adb: (Create_Standard): Set alignment of String to 1

	* einfo.ads, einfo.adb: Introduce new flag Must_Be_On_Byte_Boundary

	* exp_ch4.adb (Expand_Array_Equality): Improve efficiency of generated
	code in the common constrained array cases.

	* a-storio.adb: Change implementation to avoid possible alignment
	problems on machines requiring strict alignment (data should be moved
	as type Buffer, not type Elmt).

	* checks.adb (Apply_Array_Size_Check): Improve these checks by
	killing the overflow checks which we really do not need (64-bits is
	enough).

2004-06-25  Vincent Celier  <celier@gnat.com>

	* makegpr.adb (Is_Included_In_Global_Archive): New Boolean function
	(Add_Archives.Recursive_Add_Archives): Call Add_Archive_Path
	inconditionally for the main project.
	(Recursive_Add_Archives.Add_Archive_Path): New procedure
	(Link_Executables.Check_Time_Stamps): New procedure
	(Link_Executables.Link_Foreign): New procedure
	Changes made to reduce nesting level of this package
	(Check): New procedure
	(Add_Switches): When not in quiet output, check that a switch is not
	the concatenation of several valid switches. If it is, issue a warning.
	(Build_Global_Archive): If the global archive is rebuilt, linking need
	to be done.
	(Compile_Sources): Rebuilding a library archive does not imply
	rebuilding the global archive.
	(Build_Global_Archive): New procedure
	(Build_Library): New name for Build_Archive, now only for library
	project
	(Check_Archive_Builder): New procedure
	(Create_Global_Archive_Dependency_File): New procedure
	(Gprmake): Call Build_Global_Archive before linking
	* makegpr.adb: Use Other_Sources_Present instead of Sources_Present
	throughout.
	(Scan_Arg): Display the Copyright notice when -v is used

	* gnat_ugn.texi: Document new switch -files= (VMS qualifier /FILES=)
	for gnatls.

	* vms_data.ads: Add qualifier /MAX_NESTING=nnn (-gnatyLnnn) for GNAT
	COMPILE.
	Add new GNAT LIST qualifier /FILES=
	Added qualifier /DIRECTORY= to GNAT METRIC
	Added qualifier /FILES= to GNAT METRIC
	Added qualifier /FILES to GNAT PRETTY

	* switch.adb (Is_Front_End_Switch): Refine the test for --RTS or -fRTS,
	to take into account both versions of the switch.

	* switch-c.adb (Scan_Front_End_Switches): New switch -gnatez. Should
	always be the last switch to the gcc driver. Disable switch storing so
	that switches automatically added by the gcc driver are not put in the
	ALI file.

	* prj.adb (Project_Empty): Take into account changes in components of
	Project_Data.

	* prj.ads (Languages_Processed): New enumaration value All_Languages.

	* prj.ads (Project_Data): Remove component Lib_Elaboration: never
	used. Split Boolean component Ada_Sources_Present in two Boolean
	components Ada_Sources_Present and Other_Sources_Present.
	Minor reformatting

	* prj-env.adb (For_All_Source_Dirs.Add): Use Ada_Sources_Present
	instead of Sources_Present.
	(Set_Ada_Paths.Add.Recursive_Add): Ditto

	* prj-nmsc.adb: Minor reformatting
	(Check_Ada_Naming_Scheme): New name of procedure Check_Naming_Scheme
	(Check_Ada_Naming_Scheme_Validity): New name of previous procedure
	Check_Ada_Naming_Scheme.
	Change Sources_Present to Ada_Sources_Present or Other_Sources_Present
	throughout.

	* prj-part.adb (Post_Parse_Context_Clause): New Boolean parameter
	In_Limited.
	Make sure that all cycles where there is at least one "limited with"
	are detected.
	(Parse_Single_Project): New Boolean parameter In_Limited

	* prj-proc.adb (Recursive_Check): When Process_Languages is
	All_Languages, call first Prj.Nmsc.Ada_Check, then
	Prj.Nmsc.Other_Languages_Check.

	* prj-proc.adb (Process): Use Ada_Sources_Present or
	Other_Sources_Present (instead of Sources_Present) depending on
	Process_Languages.

	* lang-specs.h: Keep -g and -m switches in the same order, and as the
	last switches.

	* lib.adb (Switch_Storing_Enabled): New global Boolean flag
	(Disable_Switch_Storing): New procedure. Set Switch_Storing_Enabled to
	False.
	(Store_Compilation_Switch): Do nothing if Switch_Storing_Enabled is
	False.

	* lib.ads (Disable_Switch_Storing): New procedure.

	* make.adb: Modifications to reduce nesting level of this package.
	(Check_Standard_Library): New procedure
	(Gnatmake.Check_Mains): New procedure
	(Gnatmake.Create_Binder_Mapping_File): New procedure
	(Compile_Sources.Compile): Add switch -gnatez as the last option
	(Display): Never display -gnatez

	* Makefile.generic:
	When using $(MAIN_OBJECT), always use $(OBJ_DIR)/$(MAIN_OBJECT)

	* gnatcmd.adb (Check_Project): New function
	(Process_Link): New procedure to reduce nesting depth
	(Check_Files): New procedure to reduce the nesting depth.
	For GNAT METRIC, include the inherited sources in extending projects.
	(GNATCmd): When GNAT LS is invoked with a project file and no files,
	add the list of files from the sources of the project file. If this list
	is too long, put it in a temp text files and use switch -files=
	(Delete_Temp_Config_Files): Delete the temp text file that contains
	a list of source for gnatpp or gnatmetric, if one has been created.
	(GNATCmd): For GNAT METRIC and GNAT PRETTY, if the number of sources
	in the project file is too large, create a temporary text file that
	list them and pass it to the tool with "-files=<temp text file>".
	(GNATCmd): For GNAT METRIC add "-d=<abject dir>" as the first switch

	* gnatlink.adb (Gnatlink): Do not compile with --RTS= when the
	generated file is in not in Ada.

	* gnatls.adb: Remove all parameters And_Save that are no longer used.
	(Scan_Ls_Arg): Add processing for -files=
	(Usage): Add line for -files=

	* g-os_lib.adb (On_Windows): New global constant Boolean flag
	(Normalize_Pathname): When on Windows and the path starts with a
	directory separator, make sure that the resulting path will start with
	a drive letter.

	* clean.adb (Clean_Archive): New procedure
	(Clean_Project): When there is non-Ada code, delete the global archive,
	the archive dependency files, the object files and their dependency
	files, if they exist.
	(Gnatclean): Call Prj.Pars.Parse for All_Languages, not for Ada only.

2004-06-25  Thomas Quinot  <quinot@act-europe.fr>

	* sinfo.ads: Fix typo in comment.

	* sem_dist.adb (Process_Remote_AST_Attribute): Simplify code that uses
	the TSS for remote access-to-subprogram types, since these TSS are
	always present once the type has been analyzed.
	(RAS_E_Dereference): Same.

	* sem_attr.adb (Analyze_Attribute): When analysis of an attribute
	reference raises Bad_Attribute, mark the reference as analyzed so the
	node (and any children resulting from rewrites that could have occurred
	during the analysis that ultimately failed) is not analyzed again.

	* exp_ch7.ads (Find_Final_List): Fix misaligned comment.

	* exp_dist.adb: Minor comment fix.

	* exp_ch4.adb (Expand_N_Allocator): For an allocator whose expected
	type is an anonymous access type, no unchecked deallocation of the
	allocated object can occur. If the object is controlled, attach it with
	a count of 1. This allows attachment to the Global_Final_List, if
	no other relevant list is available.
	(Get_Allocator_Final_List): For an anonymous access type that is
	the type of a discriminant or record component, the corresponding
	finalisation list is the one of the scope of the type.

2004-06-25  Ed Schonberg  <schonberg@gnat.com>

	* sem_ch3.adb (Replace_Type): When computing the signature of an
	inherited subprogram, use the first subtype if the derived type
	declaration has no constraint.

	* exp_ch6.adb (Add_Call_By_Copy_Code): Check that formal is an array
	before applying previous optimization. Minor code cleanup.

	* exp_util.adb (Is_Possibly_Unaligned_Slice): If the component is
	placed at the beginning of an unpacked record without explicit
	alignment, a slice of it will be aligned and does not need a copy when
	used as an actual.

2004-06-25  Ed Schonberg  <schonberg@gnat.com>

	PR ada/15591
	PR ada/15592
	* sem_ch8.adb (Attribute_Renaming): Reject renaming if the attribute
	reference is written with expressions mimicking parameters.

2004-06-25  Hristian Kirtchev  <kirtchev@gnat.com>

	PR ada/15589
	* sem_ch3.adb (Build_Derived_Record_Type): Add additional check to
	STEP 2a. The constraints of a full type declaration of a derived record
	type are checked for conformance with those declared in the
	corresponding private extension declaration. The message
	"not conformant with previous declaration" is emitted if an error is
	detected.

2004-06-25  Vasiliy Fofanov  <fofanov@act-europe.fr>

	* g-traceb.ads: Document the need for -E binder switch in the spec.

	* g-trasym.ads: Document the need for -E binder switch in the spec.

2004-06-25  Jose Ruiz  <ruiz@act-europe.fr>

	* sem_prag.adb: Add handling of pragma Detect_Blocking.

	* snames.h, snames.ads, snames.adb: Add entry for pragma
	Detect_Blocking.

	* s-rident.ads: Change reference to pragma Detect_Blocking.

	* targparm.ads, targparm.adb: Allow pragma Detect_Blocking in
	system.ads.

	* opt.ads (Detect_Blocking): New Boolean variable (defaulted to False)
	to indicate whether pragma Detect_Blocking is active.

	* par-prag.adb: Add entry for pragma Detect_Blocking.

	* rtsfind.adb (RTU_Loaded): Fix the temporary kludge to get past bug
	of not handling WITH.
	Note that this replaces the previous update which was incorrect.

2004-06-25  Javier Miranda  <miranda@gnat.com>

	* sem_ch10.adb (Re_Install_Use_Clauses): Force the installation of the
	use-clauses to have a clean environment.

	* sem_ch8.adb (Install_Use_Clauses): Addition of a new formal to force
	the installation of the use-clauses to stablish a clean environment in
	case of compilation of a separate unit; otherwise the call to
	use_one_package is protected by the barrier Applicable_Use.

	* sem_ch8.ads (Install_Use_Clauses): Addition of a new formal to force
	the installation of the use-clauses to stablish a clean environment in
	case of compilation of a separate unit.
	(End_Use_Clauses): Minor comment cleanup.

2004-06-25  Sergey Rybin  <rybin@act-europe.fr>

	* gnat_ugn.texi: Add description of the gnatpp 'files' switch


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@83658 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 269 insertions, 154 deletions

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index d59e0b942ac..e0d5f7cb585 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -94,20 +94,21 @@ package body Exp_Ch4 is
 
    function Expand_Array_Equality
      (Nod    : Node_Id;
-      Typ    : Entity_Id;
-      A_Typ  : Entity_Id;
       Lhs    : Node_Id;
       Rhs    : Node_Id;
-      Bodies : List_Id) return Node_Id;
+      Bodies : List_Id;
+      Typ    : Entity_Id) return Node_Id;
    --  Expand an array equality into a call to a function implementing this
    --  equality, and a call to it. Loc is the location for the generated
-   --  nodes. Typ is the type of the array, and Lhs, Rhs are the array
-   --  expressions to be compared. A_Typ is the type of the arguments,
-   --  which may be a private type, in which case Typ is its full view.
+   --  nodes. Lhs and Rhs are the array expressions to be compared.
    --  Bodies is a list on which to attach bodies of local functions that
-   --  are created in the process. This is the responsibility of the
+   --  are created in the process. It is the responsibility of the
    --  caller to insert those bodies at the right place. Nod provides
-   --  the Sloc value for the generated code.
+   --  the Sloc value for the generated code. Normally the types used
+   --  for the generated equality routine are taken from Lhs and Rhs.
+   --  However, in some situations of generated code, the Etype fields
+   --  of Lhs and Rhs are not set yet. In such cases, Typ supplies the
+   --  type to be used for the formal parameters.
 
    procedure Expand_Boolean_Operator (N : Node_Id);
    --  Common expansion processing for Boolean operators (And, Or, Xor)
@@ -124,7 +125,8 @@ package body Exp_Ch4 is
    --  is a list on which to attach bodies of local functions that are
    --  created in the process. This is the responsability of the caller
    --  to insert those bodies at the right place. Nod provides the Sloc
-   --  value for generated code.
+   --  value for generated code. Lhs and Rhs are the left and right sides
+   --  for the comparison, and Typ is the type of the arrays to compare.
 
    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
    --  This routine handles expansion of concatenation operations, where
@@ -570,7 +572,7 @@ package body Exp_Ch4 is
         and then Nkind (Exp) = N_Allocator
         and then Nkind (Expression (Exp)) /= N_Qualified_Expression
       then
-         --  Apply constraint to designated subtype indication.
+         --  Apply constraint to designated subtype indication
 
          Apply_Constraint_Check (Expression (Exp),
            Designated_Type (Designated_Type (PtrT)),
@@ -858,7 +860,7 @@ package body Exp_Ch4 is
    --  Expand an equality function for multi-dimensional arrays. Here is
    --  an example of such a function for Nb_Dimension = 2
 
-   --  function Enn (A : arr; B : arr) return boolean is
+   --  function Enn (A : atyp; B : btyp) return boolean is
    --  begin
    --     if (A'length (1) = 0 or else A'length (2) = 0)
    --          and then
@@ -866,50 +868,49 @@ package body Exp_Ch4 is
    --     then
    --        return True;    -- RM 4.5.2(22)
    --     end if;
-   --
+
    --     if A'length (1) /= B'length (1)
    --               or else
    --           A'length (2) /= B'length (2)
    --     then
    --        return False;   -- RM 4.5.2(23)
    --     end if;
-   --
+
    --     declare
-   --        A1 : Index_type_1 := A'first (1)
-   --        B1 : Index_Type_1 := B'first (1)
+   --        B1 : Index_T1 := B'first (1)
    --     begin
-   --        loop
+   --        for A1 in A'range (1) loop
    --           declare
-   --              A2 : Index_type_2 := A'first (2);
-   --              B2 : Index_type_2 := B'first (2)
+   --              B2 : Index_T2 := B'first (2)
    --           begin
-   --              loop
+   --              for A2 in A'range (2) loop
    --                 if A (A1, A2) /= B (B1, B2) then
    --                    return False;
    --                 end if;
-   --
-   --                 exit when A2 = A'last (2);
-   --                 A2 := Index_type2'succ (A2);
-   --                 B2 := Index_type2'succ (B2);
+
+   --                 B2 := Index_T2'succ (B2);
    --              end loop;
    --           end;
-   --
-   --           exit when A1 = A'last (1);
-   --           A1 := Index_type1'succ (A1);
-   --           B1 := Index_type1'succ (B1);
+
+   --           B1 := Index_T1'succ (B1);
    --        end loop;
    --     end;
-   --
+
    --     return true;
    --  end Enn;
 
+   --  Note on the formal types used (atyp and btyp). If either of the
+   --  arrays is of a private type, we use the underlying type, and
+   --  do an unchecked conversion of the actual. If either of the arrays
+   --  has a bound depending on a discriminant, then we use the base type
+   --  since otherwise we have an escaped discriminant in the function.
+
    function Expand_Array_Equality
      (Nod    : Node_Id;
-      Typ    : Entity_Id;
-      A_Typ  : Entity_Id;
       Lhs    : Node_Id;
       Rhs    : Node_Id;
-      Bodies : List_Id) return Node_Id
+      Bodies : List_Id;
+      Typ    : Entity_Id) return Node_Id
    is
       Loc         : constant Source_Ptr := Sloc (Nod);
       Decls       : constant List_Id    := New_List;
@@ -924,6 +925,10 @@ package body Exp_Ch4 is
       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
 
+      Ltyp : Entity_Id;
+      Rtyp : Entity_Id;
+      --  The parameter types to be used for the formals
+
       function Arr_Attr
         (Arr : Entity_Id;
          Nam : Name_Id;
@@ -934,29 +939,37 @@ package body Exp_Ch4 is
       --  Create one statement to compare corresponding components,
       --  designated by a full set of indices.
 
+      function Get_Arg_Type (N : Node_Id) return Entity_Id;
+      --  Given one of the arguments, computes the appropriate type to
+      --  be used for that argument in the corresponding function formal
+
       function Handle_One_Dimension
         (N     : Int;
          Index : Node_Id) return Node_Id;
-      --  This procedure returns a declare block:
+      --  This procedure returns the following code
       --
       --    declare
-      --       An : Index_Type_n := A'First (n);
-      --       Bn : Index_Type_n := B'First (n);
+      --       Bn : Index_T := B'First (n);
       --    begin
-      --       loop
+      --       for An in A'range (n) loop
       --          xxx
-      --          exit when An = A'Last (n);
-      --          An := Index_Type_n'Succ (An)
-      --          Bn := Index_Type_n'Succ (Bn)
+      --          Bn := Index_T'Succ (Bn)
       --       end loop;
       --    end;
       --
+      --  Note: we don't need Bn or the declare block when the index types
+      --  of the two arrays are constrained and identical.
+      --
       --  where N is the value of "n" in the above code. Index is the
       --  N'th index node, whose Etype is Index_Type_n in the above code.
-      --  The xxx statement is either the declare block for the next
+      --  The xxx statement is either the loop or declare for the next
       --  dimension or if this is the last dimension the comparison
       --  of corresponding components of the arrays.
       --
+      --  Note: if the index types are identical and constrained, we
+      --  need only one index, so we generate only An and we do not
+      --  need the declare block.
+      --
       --  The actual way the code works is to return the comparison
       --  of corresponding components for the N+1 call. That's neater!
 
@@ -1025,6 +1038,40 @@ package body Exp_Ch4 is
                  Expression => New_Occurrence_Of (Standard_False, Loc))));
       end Component_Equality;
 
+      ------------------
+      -- Get_Arg_Type --
+      ------------------
+
+      function Get_Arg_Type (N : Node_Id) return Entity_Id is
+         T : Entity_Id;
+         X : Node_Id;
+
+      begin
+         T := Etype (N);
+
+         if No (T) then
+            return Typ;
+
+         else
+            T := Underlying_Type (T);
+
+            X := First_Index (T);
+            while Present (X) loop
+               if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
+                 or else
+                   Denotes_Discriminant (Type_High_Bound (Etype (X)))
+               then
+                  T := Base_Type (T);
+                  exit;
+               end if;
+
+               Next_Index (X);
+            end loop;
+
+            return T;
+         end if;
+      end Get_Arg_Type;
+
       --------------------------
       -- Handle_One_Dimension --
       ---------------------------
@@ -1033,70 +1080,85 @@ package body Exp_Ch4 is
         (N     : Int;
          Index : Node_Id) return Node_Id
       is
+         Need_Separate_Indexes : constant Boolean :=
+                                   Ltyp /= Rtyp
+                                     or else not Is_Constrained (Ltyp);
+         --  If the index types are identical, and we are working with
+         --  constrained types, then we can use the same index for both of
+         --  the arrays.
+
          An : constant Entity_Id := Make_Defining_Identifier (Loc,
                                       Chars => New_Internal_Name ('A'));
-         Bn : constant Entity_Id := Make_Defining_Identifier (Loc,
-                                      Chars => New_Internal_Name ('B'));
-         Index_Type_n  : Entity_Id;
+
+         Bn       : Entity_Id;
+         Index_T  : Entity_Id;
+         Stm_List : List_Id;
+         Loop_Stm : Node_Id;
 
       begin
-         if N > Number_Dimensions (Typ) then
-            return Component_Equality (Typ);
+         if N > Number_Dimensions (Ltyp) then
+            return Component_Equality (Ltyp);
          end if;
 
-         --  Case where we generate a declare block
+         --  Case where we generate a loop
+
+         Index_T := Base_Type (Etype (Index));
+
+         if Need_Separate_Indexes then
+            Bn :=
+              Make_Defining_Identifier (Loc,
+                Chars => New_Internal_Name ('B'));
+         else
+            Bn := An;
+         end if;
 
-         Index_Type_n := Base_Type (Etype (Index));
          Append (New_Reference_To (An, Loc), Index_List1);
          Append (New_Reference_To (Bn, Loc), Index_List2);
 
-         return
-            Make_Block_Statement (Loc,
-              Declarations => New_List (
-                 Make_Object_Declaration (Loc,
-                   Defining_Identifier => An,
-                   Object_Definition   =>
-                     New_Reference_To (Index_Type_n, Loc),
-                   Expression => Arr_Attr (A, Name_First, N)),
+         Stm_List := New_List (
+           Handle_One_Dimension (N + 1, Next_Index (Index)));
 
-                 Make_Object_Declaration (Loc,
-                   Defining_Identifier => Bn,
-                   Object_Definition   =>
-                     New_Reference_To (Index_Type_n, Loc),
-                   Expression => Arr_Attr (B, Name_First, N))),
-
-              Handled_Statement_Sequence =>
-                Make_Handled_Sequence_Of_Statements (Loc,
-                  Statements => New_List (
-                    Make_Implicit_Loop_Statement (Nod,
-                      Statements => New_List (
-                        Handle_One_Dimension (N + 1, Next_Index (Index)),
-
-                        Make_Exit_Statement (Loc,
-                          Condition =>
-                            Make_Op_Eq (Loc,
-                              Left_Opnd  => New_Reference_To (An, Loc),
-                              Right_Opnd => Arr_Attr (A, Name_Last, N))),
-
-                        Make_Assignment_Statement (Loc,
-                          Name => New_Reference_To (An, Loc),
-                          Expression =>
-                            Make_Attribute_Reference (Loc,
-                              Prefix =>
-                                New_Reference_To (Index_Type_n, Loc),
-                              Attribute_Name => Name_Succ,
-                              Expressions => New_List (
-                                New_Reference_To (An, Loc)))),
-
-                       Make_Assignment_Statement (Loc,
-                          Name => New_Reference_To (Bn, Loc),
-                          Expression =>
-                            Make_Attribute_Reference (Loc,
-                              Prefix =>
-                                New_Reference_To (Index_Type_n, Loc),
-                              Attribute_Name => Name_Succ,
-                              Expressions => New_List (
-                                New_Reference_To (Bn, Loc)))))))));
+         if Need_Separate_Indexes then
+            Append_To (Stm_List,
+              Make_Assignment_Statement (Loc,
+                Name       => New_Reference_To (Bn, Loc),
+                Expression =>
+                  Make_Attribute_Reference (Loc,
+                    Prefix         => New_Reference_To (Index_T, Loc),
+                    Attribute_Name => Name_Succ,
+                    Expressions    => New_List (New_Reference_To (Bn, Loc)))));
+         end if;
+
+         Loop_Stm :=
+           Make_Implicit_Loop_Statement (Nod,
+             Statements       => Stm_List,
+             Iteration_Scheme =>
+               Make_Iteration_Scheme (Loc,
+                 Loop_Parameter_Specification =>
+                   Make_Loop_Parameter_Specification (Loc,
+                     Defining_Identifier         => An,
+                     Discrete_Subtype_Definition =>
+                       Arr_Attr (A, Name_Range, N))));
+
+         --  If separate indexes, need a declare block to declare Bn
+
+         if Need_Separate_Indexes then
+            return
+              Make_Block_Statement (Loc,
+                Declarations => New_List (
+                  Make_Object_Declaration (Loc,
+                    Defining_Identifier => Bn,
+                    Object_Definition   => New_Reference_To (Index_T, Loc),
+                    Expression          => Arr_Attr (B, Name_First, N))),
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc,
+                    Statements => New_List (Loop_Stm)));
+
+         --  If no separate indexes, return loop statement on its own
+
+         else
+            return Loop_Stm;
+         end if;
       end Handle_One_Dimension;
 
       -----------------------
@@ -1113,7 +1175,7 @@ package body Exp_Ch4 is
       begin
          Alist := Empty;
          Blist := Empty;
-         for J in 1 .. Number_Dimensions (Typ) loop
+         for J in 1 .. Number_Dimensions (Ltyp) loop
             Atest :=
               Make_Op_Eq (Loc,
                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
@@ -1157,7 +1219,7 @@ package body Exp_Ch4 is
 
       begin
          Result := Empty;
-         for J in 1 .. Number_Dimensions (Typ) loop
+         for J in 1 .. Number_Dimensions (Ltyp) loop
             Rtest :=
               Make_Op_Ne (Loc,
                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
@@ -1179,14 +1241,29 @@ package body Exp_Ch4 is
    --  Start of processing for Expand_Array_Equality
 
    begin
+      Ltyp := Get_Arg_Type (Lhs);
+      Rtyp := Get_Arg_Type (Rhs);
+
+      --  For now, if the argument types are not the same, go to the
+      --  base type, since the code assumes that the formals have the
+      --  same type. This is fixable in future ???
+
+      if Ltyp /= Rtyp then
+         Ltyp := Base_Type (Ltyp);
+         Rtyp := Base_Type (Rtyp);
+         pragma Assert (Ltyp = Rtyp);
+      end if;
+
+      --  Build list of formals for function
+
       Formals := New_List (
         Make_Parameter_Specification (Loc,
           Defining_Identifier => A,
-          Parameter_Type      => New_Reference_To (Typ, Loc)),
+          Parameter_Type      => New_Reference_To (Ltyp, Loc)),
 
         Make_Parameter_Specification (Loc,
           Defining_Identifier => B,
-          Parameter_Type      => New_Reference_To (Typ, Loc)));
+          Parameter_Type      => New_Reference_To (Rtyp, Loc)));
 
       Func_Name := Make_Defining_Identifier (Loc,  New_Internal_Name ('E'));
 
@@ -1220,30 +1297,45 @@ package body Exp_Ch4 is
                       Expression =>
                         New_Occurrence_Of (Standard_False, Loc)))),
 
-                Handle_One_Dimension (1, First_Index (Typ)),
+                Handle_One_Dimension (1, First_Index (Ltyp)),
 
                 Make_Return_Statement (Loc,
                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
 
          Set_Has_Completion (Func_Name, True);
+         Set_Is_Inlined (Func_Name);
 
          --  If the array type is distinct from the type of the arguments,
          --  it is the full view of a private type. Apply an unchecked
          --  conversion to insure that analysis of the call succeeds.
 
-         if Base_Type (A_Typ) /= Base_Type (Typ) then
-            Actuals := New_List (
-              OK_Convert_To (Typ, Lhs),
-              OK_Convert_To (Typ, Rhs));
-         else
-            Actuals := New_List (Lhs, Rhs);
-         end if;
+         declare
+            L, R : Node_Id;
+
+         begin
+            L := Lhs;
+            R := Rhs;
+
+            if No (Etype (Lhs))
+              or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
+            then
+               L := OK_Convert_To (Ltyp, Lhs);
+            end if;
+
+            if No (Etype (Rhs))
+              or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
+            then
+               R := OK_Convert_To (Rtyp, Rhs);
+            end if;
+
+            Actuals := New_List (L, R);
+         end;
 
          Append_To (Bodies, Func_Body);
 
          return
            Make_Function_Call (Loc,
-             Name => New_Reference_To (Func_Name, Loc),
+             Name                   => New_Reference_To (Func_Name, Loc),
              Parameter_Associations => Actuals);
    end Expand_Array_Equality;
 
@@ -1370,8 +1462,7 @@ package body Exp_Ch4 is
          --  case of any composite type recursively containing such fields.
 
          else
-            return Expand_Array_Equality
-                     (Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
+            return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
          end if;
 
       elsif Is_Tagged_Type (Full_Type) then
@@ -2101,6 +2192,7 @@ package body Exp_Ch4 is
 
    procedure Expand_N_Allocator (N : Node_Id) is
       PtrT  : constant Entity_Id  := Etype (N);
+      Dtyp  : constant Entity_Id  := Designated_Type (PtrT);
       Desig : Entity_Id;
       Loc   : constant Source_Ptr := Sloc (N);
       Temp  : Entity_Id;
@@ -2172,8 +2264,8 @@ package body Exp_Ch4 is
          --  so that the constant is not labelled as having a nomimally
          --  unconstrained subtype.
 
-         if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
-            Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
+         if Entity (Desig) = Base_Type (Dtyp) then
+            Desig := New_Occurrence_Of (Dtyp, Loc);
          end if;
 
          Insert_Action (N,
@@ -2198,6 +2290,8 @@ package body Exp_Ch4 is
          return;
       end if;
 
+      --  Handle case of qualified expression (other than optimization above)
+
       if Nkind (Expression (N)) = N_Qualified_Expression then
          Expand_Allocator_Expression (N);
 
@@ -2219,19 +2313,19 @@ package body Exp_Ch4 is
 
       else
          declare
-            T         : constant Entity_Id  := Entity (Expression (N));
-            Init      : Entity_Id;
-            Arg1      : Node_Id;
-            Args      : List_Id;
-            Decls     : List_Id;
-            Decl      : Node_Id;
-            Discr     : Elmt_Id;
-            Flist     : Node_Id;
-            Temp_Decl : Node_Id;
-            Temp_Type : Entity_Id;
+            T            : constant Entity_Id  := Entity (Expression (N));
+            Init         : Entity_Id;
+            Arg1         : Node_Id;
+            Args         : List_Id;
+            Decls        : List_Id;
+            Decl         : Node_Id;
+            Discr        : Elmt_Id;
+            Flist        : Node_Id;
+            Temp_Decl    : Node_Id;
+            Temp_Type    : Entity_Id;
+            Attach_Level : Uint;
 
          begin
-
             if No_Initialization (N) then
                null;
 
@@ -2284,7 +2378,7 @@ package body Exp_Ch4 is
                   --  if the context is access to class wide, indicate that
                   --  the object being allocated has the right specific type.
 
-                  if Is_Class_Wide_Type (Designated_Type (PtrT)) then
+                  if Is_Class_Wide_Type (Dtyp) then
                      Arg1 := Unchecked_Convert_To (T, Arg1);
                   end if;
                end if;
@@ -2327,7 +2421,6 @@ package body Exp_Ch4 is
                --  part of the generated code for the allocator).
 
                if Has_Task (T) then
-
                   if No (Master_Id (Base_Type (PtrT))) then
 
                      --  The designated type was an incomplete type, and
@@ -2475,13 +2568,18 @@ package body Exp_Ch4 is
 
                if Controlled_Type (T) then
                   Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
-
+                  if Ekind (PtrT) = E_Anonymous_Access_Type then
+                     Attach_Level := Uint_1;
+                  else
+                     Attach_Level := Uint_2;
+                  end if;
                   Insert_Actions (N,
                     Make_Init_Call (
                       Ref          => New_Copy_Tree (Arg1),
                       Typ          => T,
                       Flist_Ref    => Flist,
-                      With_Attach  => Make_Integer_Literal (Loc, 2)));
+                      With_Attach  => Make_Integer_Literal (Loc,
+                        Attach_Level)));
                end if;
 
                if Is_CPP_Class (T) then
@@ -3283,7 +3381,6 @@ package body Exp_Ch4 is
    --  all three are available, False if any one of these is unavailable.
 
    procedure Expand_N_Op_Concat (N : Node_Id) is
-
       Opnds : List_Id;
       --  List of operands to be concatenated
 
@@ -3643,10 +3740,13 @@ package body Exp_Ch4 is
             begin
                Force_Validity_Checks := True;
                Rewrite (N,
-                 Expand_Array_Equality (N, Typl, A_Typ,
-                   Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
-
-               Insert_Actions      (N, Bodies);
+                 Expand_Array_Equality
+                  (N,
+                   Relocate_Node (Lhs),
+                   Relocate_Node (Rhs),
+                   Bodies,
+                   Typl));
+               Insert_Actions (N, Bodies);
                Analyze_And_Resolve (N, Standard_Boolean);
                Force_Validity_Checks := Save_Force_Validity_Checks;
             end;
@@ -3672,9 +3772,12 @@ package body Exp_Ch4 is
 
          else
             Rewrite (N,
-              Expand_Array_Equality (N, Typl, A_Typ,
-                Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
-
+              Expand_Array_Equality
+                (N,
+                 Relocate_Node (Lhs),
+                 Relocate_Node (Rhs),
+                 Bodies,
+                 Typl));
             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
          end if;
@@ -6510,34 +6613,46 @@ package body Exp_Ch4 is
       PtrT : Entity_Id) return Entity_Id
    is
       Loc : constant Source_Ptr := Sloc (N);
-      Acc : Entity_Id;
 
-   begin
-      --  If the context is an access parameter, we need to create
-      --  a non-anonymous access type in order to have a usable
-      --  final list, because there is otherwise no pool to which
-      --  the allocated object can belong. We create both the type
-      --  and the finalization chain here, because freezing an
-      --  internal type does not create such a chain. The Final_Chain
-      --  that is thus created is shared by the access parameter.
+      Owner : Entity_Id := PtrT;
+      --  The entity whose finalisation list must be used to attach the
+      --  allocated object.
 
+   begin
       if Ekind (PtrT) = E_Anonymous_Access_Type then
-         Acc := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
-         Insert_Action (N,
-           Make_Full_Type_Declaration (Loc,
-             Defining_Identifier => Acc,
-             Type_Definition =>
-                Make_Access_To_Object_Definition (Loc,
-                  Subtype_Indication =>
-                    New_Occurrence_Of (T, Loc))));
+         if Nkind (Associated_Node_For_Itype (PtrT))
+              in N_Subprogram_Specification
+         then
+            --  If the context is an access parameter, we need to create
+            --  a non-anonymous access type in order to have a usable
+            --  final list, because there is otherwise no pool to which
+            --  the allocated object can belong. We create both the type
+            --  and the finalization chain here, because freezing an
+            --  internal type does not create such a chain. The Final_Chain
+            --  that is thus created is shared by the access parameter.
+
+            Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+            Insert_Action (N,
+              Make_Full_Type_Declaration (Loc,
+                Defining_Identifier => Owner,
+                Type_Definition =>
+                   Make_Access_To_Object_Definition (Loc,
+                     Subtype_Indication =>
+                       New_Occurrence_Of (T, Loc))));
 
-         Build_Final_List (N, Acc);
-         Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Acc));
-         return Find_Final_List (Acc);
+            Build_Final_List (N, Owner);
+            Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
 
-      else
-         return Find_Final_List (PtrT);
+         else
+            --  Case of an access discriminant, or (Ada 2005) of
+            --  an anonymous access component: find the final list
+            --  associated with the scope of the type.
+
+            Owner := Scope (PtrT);
+         end if;
       end if;
+
+      return Find_Final_List (Owner);
    end Get_Allocator_Final_List;
 
    -------------------------------