[multiple changes]
authorArnaud Charlet <charlet@gcc.gnu.org>
Mon, 24 May 2004 15:19:11 +0000 (17:19 +0200)
committerArnaud Charlet <charlet@gcc.gnu.org>
Mon, 24 May 2004 15:19:11 +0000 (17:19 +0200)
2004-05-24  Geert Bosch  <bosch@gnat.com>

* a-numaux-x86.adb (Reduce): Reimplement using an approximation of Pi
with 192 bits of precision, sufficient to reduce a double-extended
arguments X with a maximum relative error of T'Machine_Epsilon, for X
in -2.0**32 .. 2.0**32.
(Cos, Sin):  Always reduce arguments of 1/4 Pi or larger, to prevent
reduction by the processor, which only uses a 68-bit approximation of
Pi.
(Tan): Always reduce arguments and compute function either using
the processor's fptan instruction, or by dividing sin and cos as needed.

2004-05-24  Doug Rupp  <rupp@gnat.com>

* adaint.c (__gnat_readdir): Cast CRTL function retun value to avoid
gcc error on 32/64 bit VMS.

2004-05-24  Olivier Hainque  <hainque@act-europe.fr>

* init.c (__gnat_error_handler): Handle EEXIST as EACCES for SIGSEGVs,
since this is what we get for stack overflows although not documented
as such.
Document the issues which may require adjustments to our signal
handlers.

2004-05-24  Ed Schonberg  <schonberg@gnat.com>

* inline.adb (Add_Scope_To_Clean): Do not add cleanup actions to the
enclosing dynamic scope if the instantiation is within a generic unit.

2004-05-24  Arnaud Charlet  <charlet@act-europe.fr>

* exp_dbug.ads: Fix typo.

* Makefile.in: s-osinte-linux-ia64.ads was misnamed.
Rename it to its proper name: system-linux-ia64.ads
(stamp-gnatlib1): Remove extra target specific run time files when
setting up the rts directory.

2004-05-24  Javier Miranda  <miranda@gnat.com>

* einfo.ads, einfo.adb (Limited_Views): Removed.
(Limited_View): New attribute that replaces the previous one. It is
now a bona fide package with the limited-view list through the
first_entity and first_private attributes.

* sem_ch10.adb (Install_Private_With_Clauses): Give support to
limited-private-with clause.
(Install_Limited_Withed_Unit): Install the private declarations of a
limited-private-withed package. Update the installation of the shadow
entities according to the new structure (see Build_Limited_Views)
(Build_Limited_Views): Replace the previous implementation of the
limited view by a package entity that references the first shadow
entity plus the first shadow private entity (required for limited-
private-with clause)
(New_Internal_Shadow_Entity): Code cleanup.
(Remove_Limited_With_Clause): Update the implementation to undo the
new work carried out by Build_Limited_Views.
(Build_Chain): Complete documentation.
Replace Ada0Y by Ada 0Y in comments
Minor reformating

* sem_ch3.adb (Array_Type_Declaration): In case of anonymous access
types the level of accessibility depends on the enclosing type
declaration.

* sem_ch8.adb (Find_Expanded_Name): Fix condition to detect shadow
entities. Complete documentation of previous change.

2004-05-24  Robert Dewar  <dewar@gnat.com>

* namet.adb: Minor reformatting
Avoid use of name I (replace by J)
Minor code restructuring

* sem_ch6.adb: Minor reformatting

* lib-writ.adb: Do not set restriction as active if this is a
Restriction_Warning case.

* sem_prag.adb: Reset restriction warning flag if real pragma
restriction encountered.

* s-htable.adb: Minor reformatting
Change rotate count to 3 in Hash (improves hash for small strings)

* 5qsystem.ads: Add comments for type Address (no literals allowed).

* gnat_ugn.texi: Add new section of documentation "Code Generation
Control", which describes the use of -m switches.

2004-05-24  Eric Botcazou  <ebotcazou@act-europe.fr>

(tree_transform) <N_Identifier>: Do the dereference directly through
the DECL_INITIAL for renamed variables.

From-SVN: r82205

20 files changed:
gcc/ada/5qsystem.ads
gcc/ada/ChangeLog
gcc/ada/Makefile.in
gcc/ada/a-numaux-x86.adb
gcc/ada/adaint.c
gcc/ada/einfo.adb
gcc/ada/einfo.ads
gcc/ada/exp_dbug.ads
gcc/ada/gnat_ugn.texi
gcc/ada/init.c
gcc/ada/inline.adb
gcc/ada/lib-writ.adb
gcc/ada/namet.adb
gcc/ada/s-htable.adb
gcc/ada/sem_ch10.adb
gcc/ada/sem_ch3.adb
gcc/ada/sem_ch6.adb
gcc/ada/sem_ch8.adb
gcc/ada/sem_prag.adb
gcc/ada/trans.c

index c8b94936ded38abc4ec80c57eba1097f4ee271ae..9052e2b16bb14da59825a475266dd65a3a52259c 100644 (file)
@@ -64,6 +64,14 @@ pragma Pure (System);
 
    type Address is new Long_Integer;
    Null_Address : constant Address;
+   --  Although this is declared as an integer type, no arithmetic operations
+   --  are available (see abstract declarations below), and furthermore there
+   --  is special processing in the compiler that prevents the use of integer
+   --  literals with this type (use To_Address to convert integer literals).
+   --
+   --  Conversion to and from Short_Address is however freely permitted, and
+   --  is indeed the reason that Address is declared as an integer type. See
+   --
 
    Storage_Unit : constant := 8;
    Word_Size    : constant := 64;
index 126ecae5d0cbb14b148af28fd78bbab90fa0cfeb..a8a95d1b1b8b0799b4677977fa2dc6d44198421e 100644 (file)
@@ -1,3 +1,99 @@
+2004-05-24  Geert Bosch  <bosch@gnat.com>
+
+       * a-numaux-x86.adb (Reduce): Reimplement using an approximation of Pi
+       with 192 bits of precision, sufficient to reduce a double-extended
+       arguments X with a maximum relative error of T'Machine_Epsilon, for X
+       in -2.0**32 .. 2.0**32.
+       (Cos, Sin):  Always reduce arguments of 1/4 Pi or larger, to prevent
+       reduction by the processor, which only uses a 68-bit approximation of
+       Pi.
+       (Tan): Always reduce arguments and compute function either using
+       the processor's fptan instruction, or by dividing sin and cos as needed.
+
+2004-05-24  Doug Rupp  <rupp@gnat.com>
+
+       * adaint.c (__gnat_readdir): Cast CRTL function retun value to avoid
+       gcc error on 32/64 bit VMS.
+
+2004-05-24  Olivier Hainque  <hainque@act-europe.fr>
+
+       * init.c (__gnat_error_handler): Handle EEXIST as EACCES for SIGSEGVs,
+       since this is what we get for stack overflows although not documented
+       as such.
+       Document the issues which may require adjustments to our signal
+       handlers.
+
+2004-05-24  Ed Schonberg  <schonberg@gnat.com>
+
+       * inline.adb (Add_Scope_To_Clean): Do not add cleanup actions to the
+       enclosing dynamic scope if the instantiation is within a generic unit.
+
+2004-05-24  Arnaud Charlet  <charlet@act-europe.fr>
+
+       * exp_dbug.ads: Fix typo.
+
+       * Makefile.in: s-osinte-linux-ia64.ads was misnamed.
+       Rename it to its proper name: system-linux-ia64.ads
+       (stamp-gnatlib1): Remove extra target specific run time files when
+       setting up the rts directory.
+
+2004-05-24  Javier Miranda  <miranda@gnat.com>
+
+       * einfo.ads, einfo.adb (Limited_Views): Removed.
+       (Limited_View): New attribute that replaces the previous one. It is
+       now a bona fide package with the limited-view list through the
+       first_entity and first_private attributes.
+
+       * sem_ch10.adb (Install_Private_With_Clauses): Give support to
+       limited-private-with clause.
+       (Install_Limited_Withed_Unit): Install the private declarations of a
+       limited-private-withed package. Update the installation of the shadow
+       entities according to the new structure (see Build_Limited_Views)
+       (Build_Limited_Views): Replace the previous implementation of the
+       limited view by a package entity that references the first shadow
+       entity plus the first shadow private entity (required for limited-
+       private-with clause)
+       (New_Internal_Shadow_Entity): Code cleanup.
+       (Remove_Limited_With_Clause): Update the implementation to undo the
+       new work carried out by Build_Limited_Views.
+       (Build_Chain): Complete documentation.
+       Replace Ada0Y by Ada 0Y in comments
+       Minor reformating
+
+       * sem_ch3.adb (Array_Type_Declaration): In case of anonymous access
+       types the level of accessibility depends on the enclosing type
+       declaration.
+
+       * sem_ch8.adb (Find_Expanded_Name): Fix condition to detect shadow
+       entities. Complete documentation of previous change.
+
+2004-05-24  Robert Dewar  <dewar@gnat.com>
+
+       * namet.adb: Minor reformatting
+       Avoid use of name I (replace by J)
+       Minor code restructuring
+
+       * sem_ch6.adb: Minor reformatting
+
+       * lib-writ.adb: Do not set restriction as active if this is a
+       Restriction_Warning case.
+
+       * sem_prag.adb: Reset restriction warning flag if real pragma
+       restriction encountered.
+
+       * s-htable.adb: Minor reformatting
+       Change rotate count to 3 in Hash (improves hash for small strings)
+
+       * 5qsystem.ads: Add comments for type Address (no literals allowed).
+
+       * gnat_ugn.texi: Add new section of documentation "Code Generation
+       Control", which describes the use of -m switches.
+
+2004-05-24  Eric Botcazou  <ebotcazou@act-europe.fr>
+
+       (tree_transform) <N_Identifier>: Do the dereference directly through
+       the DECL_INITIAL for renamed variables.
+
 2004-05-24  Arnaud Charlet  <charlet@act-europe.fr>
 
        * s-osinte-linux-ia64.ads: Renamed system-linux-ia64.ads
index a094a82830e4cf38979d707792d7ae16824ef6d2..79d404516e70cba4e8762fb77895f3c5ee526cae 100644 (file)
@@ -1268,7 +1268,7 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
   s-taprop.adb<s-taprop-linux.adb \
   s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
   s-taspri.ads<s-taspri-linux.ads \
-  system.ads<s-osinte-linux-ia64.ads
+  system.ads<system-linux-ia64.ads
 
   TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-linux.adb
   MISCLIB=
@@ -1663,6 +1663,7 @@ install-gnatlib: ../stamp-gnatlib
 # Remove files to be replaced by target dependent sources
        $(RM) $(foreach PAIR,$(LIBGNAT_TARGET_PAIRS), \
                        rts/$(word 1,$(subst <, ,$(PAIR))))
+       $(RM) rts/*-*-*.ads rts/*-*-*.adb
 # Copy new target dependent sources
        $(foreach PAIR,$(LIBGNAT_TARGET_PAIRS), \
                  $(LN_S) $(fsrcpfx)$(word 2,$(subst <, ,$(PAIR))) \
index a13733305a1a37b0ac8fad9d71aa49bba9557459..b11867036f2cab33efc2bbfd339232b4073d368f 100644 (file)
@@ -7,7 +7,7 @@
 --                                 B o d y                                  --
 --                        (Machine Version for x86)                         --
 --                                                                          --
---          Copyright (C) 1998-2001 Free Software Foundation, Inc.          --
+--          Copyright (C) 1998-2004 Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -41,61 +41,7 @@ with System.Machine_Code; use System.Machine_Code;
 
 package body Ada.Numerics.Aux is
 
-   NL           : constant String := ASCII.LF & ASCII.HT;
-
-   type FPU_Stack_Pointer is range 0 .. 7;
-   for FPU_Stack_Pointer'Size use 3;
-
-   type FPU_Status_Word is record
-      B   : Boolean; -- FPU Busy (for 8087 compatibility only)
-      ES  : Boolean; -- Error Summary Status
-      SF  : Boolean; -- Stack Fault
-
-      Top : FPU_Stack_Pointer;
-
-      --  Condition Code Flags
-
-      --  C2 is set by FPREM and FPREM1 to indicate incomplete reduction.
-      --  In case of successfull recorction, C0, C3 and C1 are set to the
-      --  three least significant bits of the result (resp. Q2, Q1 and Q0).
-
-      --  C2 is used by FPTAN, FSIN, FCOS, and FSINCOS to indicate that
-      --  that source operand is beyond the allowable range of
-      --  -2.0**63 .. 2.0**63.
-
-      C3  : Boolean;
-      C2  : Boolean;
-      C1  : Boolean;
-      C0  : Boolean;
-
-      --  Exception Flags
-
-      PE  : Boolean; -- Precision
-      UE  : Boolean; -- Underflow
-      OE  : Boolean; -- Overflow
-      ZE  : Boolean; -- Zero Divide
-      DE  : Boolean; -- Denormalized Operand
-      IE  : Boolean; -- Invalid Operation
-   end record;
-
-   for FPU_Status_Word use record
-      B   at 0 range 15 .. 15;
-      C3  at 0 range 14 .. 14;
-      Top at 0 range 11 .. 13;
-      C2  at 0 range 10 .. 10;
-      C1  at 0 range  9 ..  9;
-      C0  at 0 range  8 ..  8;
-      ES  at 0 range  7 ..  7;
-      SF  at 0 range  6 ..  6;
-      PE  at 0 range  5 ..  5;
-      UE  at 0 range  4 ..  4;
-      OE  at 0 range  3 ..  3;
-      ZE  at 0 range  2 ..  2;
-      DE  at 0 range  1 ..  1;
-      IE  at 0 range  0 ..  0;
-   end record;
-
-   for FPU_Status_Word'Size use 16;
+   NL : constant String := ASCII.LF & ASCII.HT;
 
    -----------------------
    -- Local subprograms --
@@ -109,12 +55,9 @@ package body Ada.Numerics.Aux is
    --  to calculate the exponentiation. This is used by Pow for values
    --  for values of Y in the open interval (-0.25, 0.25)
 
-   function Reduce (X : Double) return Double;
-   --  Implement partial reduction of X by Pi in the x86.
-
-   --  Note that for the Sin, Cos and Tan functions completely accurate
-   --  reduction of the argument is done for arguments in the range of
-   --  -2.0**63 .. 2.0**63, using a 66-bit approximation of Pi.
+   procedure Reduce (X : in out Double; Q : out Natural);
+   --  Implements reduction of X by Pi/2. Q is the quadrant of the final
+   --  result in the range 0 .. 3. The absolute value of X is at most Pi.
 
    pragma Inline (Is_Nan);
    pragma Inline (Reduce);
@@ -123,9 +66,8 @@ package body Ada.Numerics.Aux is
    --  Basic Elementary Functions --
    ---------------------------------
 
-   --  This section implements a few elementary functions that are
-   --  used to build the more complex ones. This ordering enables
-   --  better inlining.
+   --  This section implements a few elementary functions that are used to
+   --  build the more complex ones. This ordering enables better inlining.
 
    ----------
    -- Atan --
@@ -206,20 +148,45 @@ package body Ada.Numerics.Aux is
    -- Reduce --
    ------------
 
-   function Reduce (X : Double) return Double is
-      Result : Double;
+   procedure Reduce (X : in out Double; Q : out Natural) is
+      Half_Pi     : constant := Pi / 2.0;
+      Two_Over_Pi : constant := 2.0 / Pi;
+
+      HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size);
+      M  : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant
+      P1 : constant Double := Double'Leading_Part (Half_Pi, HM);
+      P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM);
+      P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM);
+      P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM);
+      P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3
+                                                                 - P4, HM);
+      P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5);
+      K  : Double := X * Two_Over_Pi;
    begin
-      Asm
-        (Template =>
-         --  Partial argument reduction
-         "fldpi                " & NL
-       & "fadd    %%st(0), %%st" & NL
-       & "fxch    %%st(1)      " & NL
-       & "fprem1               " & NL
-       & "fstp    %%st(1)      ",
-         Outputs  => Double'Asm_Output ("=t", Result),
-         Inputs   => Double'Asm_Input  ("0", X));
-      return Result;
+      --  For X < 2.0**32, all products below are computed exactly.
+      --  Due to cancellation effects all subtractions are exact as well.
+      --  As no double extended floating-point number has more than 75
+      --  zeros after the binary point, the result will be the correctly
+      --  rounded result of X - K * (Pi / 2.0).
+
+      while abs K >= 2.0**HM loop
+         K := K * M - (K * M - K);
+         X := (((((X - K * P1) - K * P2) - K * P3)
+                     - K * P4) - K * P5) - K * P6;
+         K := X * Two_Over_Pi;
+      end loop;
+
+      if K /= K then
+
+         --  K is not a number, because X was not finite
+
+         raise Constraint_Error;
+      end if;
+
+      K := Double'Rounding (K);
+      Q := Integer (K) mod 4;
+      X := (((((X - K * P1) - K * P2) - K * P3)
+                  - K * P4) - K * P5) - K * P6;
    end Reduce;
 
    ----------
@@ -241,9 +208,9 @@ package body Ada.Numerics.Aux is
       return Result;
    end Sqrt;
 
-   ---------------------------------
-   --  Other Elementary Functions --
-   ---------------------------------
+   --------------------------------
+   -- Other Elementary Functions --
+   --------------------------------
 
    --  These are built using the previously implemented basic functions
 
@@ -253,6 +220,7 @@ package body Ada.Numerics.Aux is
 
    function Acos (X : Double) return Double is
       Result  : Double;
+
    begin
       Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
 
@@ -271,8 +239,8 @@ package body Ada.Numerics.Aux is
 
    function Asin (X : Double) return Double is
       Result  : Double;
-   begin
 
+   begin
       Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
 
       --  The result value is NaN iff input was invalid
@@ -289,29 +257,38 @@ package body Ada.Numerics.Aux is
    ---------
 
    function Cos (X : Double) return Double is
-      Reduced_X : Double := X;
+      Reduced_X : Double := abs X;
       Result    : Double;
-      Status    : FPU_Status_Word;
+      Quadrant  : Natural range 0 .. 3;
 
    begin
+      if Reduced_X > Pi / 4.0 then
+         Reduce (Reduced_X, Quadrant);
+
+         case Quadrant is
+            when 0 =>
+               Asm (Template  => "fcos",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+            when 1 =>
+               Asm (Template  => "fsin",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", -Reduced_X));
+            when 2 =>
+               Asm (Template  => "fcos ; fchs",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+            when 3 =>
+               Asm (Template  => "fsin",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+         end case;
 
-      loop
-         Asm
-           (Template =>
-            "fcos                 " & NL
-          & "xorl    %%eax, %%eax " & NL
-          & "fnstsw  %%ax         ",
-            Outputs  => (Double'Asm_Output         ("=t", Result),
-                        FPU_Status_Word'Asm_Output ("=a", Status)),
-            Inputs   => Double'Asm_Input           ("0", Reduced_X));
-
-         exit when not Status.C2;
-
-         --  Original argument was not in range and the result
-         --  is the unmodified argument.
-
-         Reduced_X := Reduce (Result);
-      end loop;
+      else
+         Asm (Template  => "fcos",
+              Outputs  => Double'Asm_Output ("=t", Result),
+              Inputs   => Double'Asm_Input  ("0", Reduced_X));
+      end if;
 
       return Result;
    end Cos;
@@ -322,7 +299,6 @@ package body Ada.Numerics.Aux is
 
    function Logarithmic_Pow (X, Y : Double) return Double is
       Result  : Double;
-
    begin
       Asm (Template => ""             --  X                  : Y
        & "fyl2x                " & NL --  Y * Log2 (X)
@@ -339,7 +315,6 @@ package body Ada.Numerics.Aux is
          Inputs   =>
            (Double'Asm_Input  ("0", X),
             Double'Asm_Input  ("u", Y)));
-
       return Result;
    end Logarithmic_Pow;
 
@@ -351,8 +326,7 @@ package body Ada.Numerics.Aux is
       type Mantissa_Type is mod 2**Double'Machine_Mantissa;
       --  Modular type that can hold all bits of the mantissa of Double
 
-      --  For negative exponents, a division is done
-      --  at the end of the processing.
+      --  For negative exponents, do divide at the end of the processing
 
       Negative_Y : constant Boolean := Y < 0.0;
       Abs_Y      : constant Double := abs Y;
@@ -370,8 +344,7 @@ package body Ada.Numerics.Aux is
       Factor : Double := 1.0;
 
    begin
-      --  Select algorithm for calculating Pow:
-      --  integer cases fall through
+      --  Select algorithm for calculating Pow (integer cases fall through)
 
       if Exp_High >= 2.0**Double'Machine_Mantissa then
 
@@ -395,7 +368,6 @@ package body Ada.Numerics.Aux is
 
       elsif Exp_High /= Abs_Y then
          Exp_Low := Abs_Y - Exp_High;
-
          Factor := 1.0;
 
          if Exp_Low /= 0.0 then
@@ -473,27 +445,36 @@ package body Ada.Numerics.Aux is
    function Sin (X : Double) return Double is
       Reduced_X : Double := X;
       Result    : Double;
-      Status    : FPU_Status_Word;
+      Quadrant  : Natural range 0 .. 3;
 
    begin
+      if abs X > Pi / 4.0 then
+         Reduce (Reduced_X, Quadrant);
+
+         case Quadrant is
+            when 0 =>
+               Asm (Template  => "fsin",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+            when 1 =>
+               Asm (Template  => "fcos",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+            when 2 =>
+               Asm (Template  => "fsin",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", -Reduced_X));
+            when 3 =>
+               Asm (Template  => "fcos ; fchs",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+         end case;
 
-      loop
-         Asm
-           (Template =>
-            "fsin                 " & NL
-          & "xorl    %%eax, %%eax " & NL
-          & "fnstsw  %%ax         ",
-            Outputs  => (Double'Asm_Output          ("=t", Result),
-                         FPU_Status_Word'Asm_Output ("=a", Status)),
-            Inputs   => Double'Asm_Input            ("0", Reduced_X));
-
-         exit when not Status.C2;
-
-         --  Original argument was not in range and the result
-         --  is the unmodified argument.
-
-         Reduced_X := Reduce (Result);
-      end loop;
+      else
+         Asm (Template  => "fsin",
+            Outputs  => Double'Asm_Output ("=t", Result),
+            Inputs   => Double'Asm_Input  ("0", Reduced_X));
+      end if;
 
       return Result;
    end Sin;
@@ -505,30 +486,34 @@ package body Ada.Numerics.Aux is
    function Tan (X : Double) return Double is
       Reduced_X : Double := X;
       Result    : Double;
-      Status    : FPU_Status_Word;
+      Quadrant  : Natural range 0 .. 3;
 
    begin
+      if abs X > Pi / 4.0 then
+         Reduce (Reduced_X, Quadrant);
+
+         if Quadrant mod 2 = 0 then
+            Asm (Template  => "fptan" & NL
+                            & "ffree   %%st(0)"  & NL
+                            & "fincstp",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+         else
+            Asm (Template  => "fsincos" & NL
+                            & "fdivp   %%st(1)" & NL
+                            & "fchs",
+                  Outputs  => Double'Asm_Output ("=t", Result),
+                  Inputs   => Double'Asm_Input  ("0", Reduced_X));
+         end if;
 
-      loop
-         Asm
-           (Template =>
-            "fptan                " & NL
-          & "xorl    %%eax, %%eax " & NL
-          & "fnstsw  %%ax         " & NL
-          & "ffree   %%st(0)      " & NL
-          & "fincstp              ",
-
-            Outputs  => (Double'Asm_Output         ("=t", Result),
-                        FPU_Status_Word'Asm_Output ("=a", Status)),
-            Inputs   => Double'Asm_Input           ("0", Reduced_X));
-
-         exit when not Status.C2;
-
-         --  Original argument was not in range and the result
-         --  is the unmodified argument.
-
-         Reduced_X := Reduce (Result);
-      end loop;
+      else
+         Asm (Template  =>
+               "fptan                 " & NL
+             & "ffree   %%st(0)      " & NL
+             & "fincstp              ",
+               Outputs  => Double'Asm_Output ("=t", Result),
+               Inputs   => Double'Asm_Input  ("0", Reduced_X));
+      end if;
 
       return Result;
    end Tan;
@@ -543,11 +528,9 @@ package body Ada.Numerics.Aux is
 
       if abs X < 25.0 then
          return (Exp (X) - Exp (-X)) / 2.0;
-
       else
          return Exp (X) / 2.0;
       end if;
-
    end Sinh;
 
    ----------
@@ -560,11 +543,9 @@ package body Ada.Numerics.Aux is
 
       if abs X < 22.0 then
          return (Exp (X) + Exp (-X)) / 2.0;
-
       else
          return Exp (X) / 2.0;
       end if;
-
    end Cosh;
 
    ----------
@@ -574,7 +555,7 @@ package body Ada.Numerics.Aux is
    function Tanh (X : Double) return Double is
    begin
       --  Return the Hyperbolic Tangent of x
-      --
+
       --                                    x    -x
       --                                   e  - e        Sinh (X)
       --       Tanh (X) is defined to be -----------   = --------
@@ -586,7 +567,6 @@ package body Ada.Numerics.Aux is
       end if;
 
       return 1.0 / (1.0 + Exp (-2.0 * X)) - 1.0 / (1.0 + Exp (2.0 * X));
-
    end Tanh;
 
 end Ada.Numerics.Aux;
index 7b8813ab6ee19d8c06088dc4a46405173cfa72c5..92573fd46d582c4d70a40df1413d6c105371c9a4 100644 (file)
@@ -806,7 +806,7 @@ __gnat_readdir (DIR *dirp, char *buffer)
     return NULL;
 
 #else
-  struct dirent *dirent = readdir (dirp);
+  struct dirent *dirent = (struct dirent *) readdir (dirp);
 
   if (dirent != NULL)
     {
index b2ad23f4da16ba3a15b748848cc89d28d2afd94d..df32596a9427fa6d4034ded6f1dd68e1cda9050b 100644 (file)
@@ -205,7 +205,7 @@ package body Einfo is
    --    Inner_Instances                 Elist23
    --    Enum_Pos_To_Rep                 Node23
    --    Packed_Array_Type               Node23
-   --    Limited_Views                   Elist23
+   --    Limited_View                    Node23
    --    Privals_Chain                   Elist23
    --    Protected_Operation             Node23
 
@@ -1708,11 +1708,11 @@ package body Einfo is
       return Node20 (Id);
    end Last_Entity;
 
-   function Limited_Views (Id : E) return L is
+   function Limited_View (Id : E) return E is
    begin
       pragma Assert (Ekind (Id) = E_Package);
-      return Elist23 (Id);
-   end Limited_Views;
+      return Node23 (Id);
+   end Limited_View;
 
    function Lit_Indexes (Id : E) return E is
    begin
@@ -3666,11 +3666,11 @@ package body Einfo is
       Set_Node20 (Id, V);
    end Set_Last_Entity;
 
-   procedure Set_Limited_Views (Id : E; V : L) is
+   procedure Set_Limited_View (Id : E; V : E) is
    begin
       pragma Assert (Ekind (Id) = E_Package);
-      Set_Elist23 (Id, V);
-   end Set_Limited_Views;
+      Set_Node23 (Id, V);
+   end Set_Limited_View;
 
    procedure Set_Lit_Indexes (Id : E; V : E) is
    begin
index 6487a22012e5fd36e40bd34772e5d35cf34bf94a..3b5c5bc033bbd583cc22203642850df682230dfd 100644 (file)
@@ -2391,11 +2391,12 @@ package Einfo is
 --       Points to a the last entry in the list of associated entities chained
 --       through the Next_Entity field. Empty if no entities are chained.
 
---    Limited_Views (Elist23)
---       Present in non-generic package entities that are not instances.
---       The elements of this list are the shadow entities created for the
---       types and local packages that are declared in a package that appears
---       in a limited_with clause (Ada0Y: AI-50217)
+--    Limited_View (Node23)
+--       Present in non-generic package entities that are not instances. Bona
+--       fide package with the limited-view list through the first_entity and
+--       first_private attributes. The elements of this list are the shadow
+--       entities created for the types and local packages that are declared
+--       in a package that appears in a limited_with clause (Ada0Y: AI-50217)
 
 --    Lit_Indexes (Node15)
 --       Present in enumeration types and subtypes. Non-empty only for the
@@ -4454,7 +4455,7 @@ package Einfo is
    --    Scope_Depth_Value             (Uint22)
    --    Generic_Renamings             (Elist23)  (for an instance)
    --    Inner_Instances               (Elist23)  (generic case only)
-   --    Limited_Views                 (Elist23)  (non-generic, not instance)
+   --    Limited_View                  (Node23)   (non-generic, not instance)
    --    Delay_Subprogram_Descriptors  (Flag50)
    --    Body_Needed_For_SAL           (Flag40)
    --    Discard_Names                 (Flag88)
@@ -5187,7 +5188,7 @@ package Einfo is
    function Kill_Range_Checks                  (Id : E) return B;
    function Kill_Tag_Checks                    (Id : E) return B;
    function Last_Entity                        (Id : E) return E;
-   function Limited_Views                      (Id : E) return L;
+   function Limited_View                       (Id : E) return E;
    function Lit_Indexes                        (Id : E) return E;
    function Lit_Strings                        (Id : E) return E;
    function Machine_Radix_10                   (Id : E) return B;
@@ -5661,7 +5662,7 @@ package Einfo is
    procedure Set_Kill_Range_Checks             (Id : E; V : B := True);
    procedure Set_Kill_Tag_Checks               (Id : E; V : B := True);
    procedure Set_Last_Entity                   (Id : E; V : E);
-   procedure Set_Limited_Views                 (Id : E; V : L);
+   procedure Set_Limited_View                  (Id : E; V : E);
    procedure Set_Lit_Indexes                   (Id : E; V : E);
    procedure Set_Lit_Strings                   (Id : E; V : E);
    procedure Set_Machine_Radix_10              (Id : E; V : B := True);
@@ -6187,7 +6188,7 @@ package Einfo is
    pragma Inline (Kill_Range_Checks);
    pragma Inline (Kill_Tag_Checks);
    pragma Inline (Last_Entity);
-   pragma Inline (Limited_Views);
+   pragma Inline (Limited_View);
    pragma Inline (Lit_Indexes);
    pragma Inline (Lit_Strings);
    pragma Inline (Machine_Radix_10);
@@ -6496,7 +6497,7 @@ package Einfo is
    pragma Inline (Set_Kill_Range_Checks);
    pragma Inline (Set_Kill_Tag_Checks);
    pragma Inline (Set_Last_Entity);
-   pragma Inline (Set_Limited_Views);
+   pragma Inline (Set_Limited_View);
    pragma Inline (Set_Lit_Indexes);
    pragma Inline (Set_Lit_Strings);
    pragma Inline (Set_Machine_Radix_10);
index 080e86615649b70fe04e3aba7d947207e5e33839..0abca3055ca128227ffe5d07c5fea43d5d389f64 100644 (file)
@@ -104,7 +104,7 @@ package Exp_Dbug is
       --    __nn  (two underscores)
 
       --  where nn is a serial number (2 for the second overloaded function,
-      --  2 for the third, etc.). A suffix of __1 is always omitted (i.e. no
+      --  3 for the third, etc.). A suffix of __1 is always omitted (i.e. no
       --  suffix implies the first instance).
 
       --  These names are prefixed by the normal full qualification. So
index 1a30c465a5531d49d6e860688c5bc8cf433f1358..c75882bc78cd31f12ecb7df77f3341d7b6e9d752 100644 (file)
@@ -3646,6 +3646,7 @@ describe the switches in more detail in functionally grouped sections.
 * Exception Handling Control::
 * Units to Sources Mapping Files::
 * Integrated Preprocessing::
+* Code Generation Control::
 @ifset vms
 * Return Codes::
 @end ifset
@@ -6534,6 +6535,35 @@ This switch is similar to switch @option{^-D^/ASSOCIATE^} of @code{gnatprep}.
 
 @end table
 
+@node Code Generation Control
+@subsection Code Generation Control
+
+@noindent
+
+The GCC technology provides a wide range of target dependent
+@option{-m} switches for controlling
+details of code generation with respect to different versions of
+architectures. This includes variations in instruction sets (e.g.
+different members of the power pc family), and different requirements
+for optimal arrangement of instructions (e.g. different members of
+the x86 family). The list of available @option{-m} switches may be
+found in the GCC documentation.
+
+Use of the these @option{-m} switches may in some cases result in improved
+code performance.
+
+The GNAT Pro technology is tested and qualified without any
+@option{-m} switches,
+so generally the most reliable approach is to avoid the use of these
+switches. However, we generally expect most of these switches to work
+successfully with GNAT Pro, and many customers have reported successful
+use of these options.
+
+Our general advice is to avoid the use of @option{-m} switches unless
+special needs lead to requirements in this area. In particular,
+there is no point in using @option{-m} switches to improve performance
+unless you actually see a performance improvement.
+
 @ifset vms
 @node Return Codes
 @subsection Return Codes
index b27e059ed9d16f64fb8c367cf8c3e3cf92809189..9d79b6c3c0e233f87b286b8313c2e3f2a92d237e 100644 (file)
@@ -262,6 +262,51 @@ __gnat_set_globals (int main_priority,
    at all; the intention is that this be replaced by system specific
    code where initialization is required. */
 
+/* Notes on the Zero Cost Exceptions scheme and its impact on the signal
+   handlers implemented below :
+
+   What we call Zero Cost Exceptions is implemented using the GCC eh
+   circuitry, even if the underlying implementation is setjmp/longjmp
+   based. In any case ...
+
+   The GCC unwinder expects to be dealing with call return addresses, since
+   this is the "nominal" case of what we retrieve while unwinding a regular
+   call chain. To evaluate if a handler applies at some point in this chain,
+   the propagation engine needs to determine what region the corresponding
+   call instruction pertains to. The return address may not be attached to the
+   same region as the call, so the unwinder unconditionally substracts "some"
+   amount to the return addresses it gets to search the region tables. The
+   exact amount is computed to ensure that the resulting address is inside the
+   call instruction, and is thus target dependant (think about delay slots for
+   instance).
+
+   When we raise an exception from a signal handler, e.g. to transform a
+   SIGSEGV into Storage_Error, things need to appear as if the signal handler
+   had been "called" by the instruction which triggered the signal, so that
+   exception handlers that apply there are considered. What the unwinder will
+   retrieve as the return address from the signal handler is what it will find
+   as the faulting instruction address in the corresponding signal context
+   pushed by the kernel. Leaving this address untouched may loose, because if
+   the triggering instruction happens to be the very first of a region, the
+   later adjustements performed by the unwinder would yield an address outside
+   that region. We need to compensate for those adjustments at some point,
+   which we currently do in the GCC unwinding fallback macro.
+
+   The thread at http://gcc.gnu.org/ml/gcc-patches/2004-05/msg00343.html
+   describes a couple of issues with our current approach. Basically: on some
+   targets the adjustment to apply depends on the triggering signal, which is
+   not easily accessible from the macro, and we actually do not tackle this as
+   of today. Besides, other languages, e.g. Java, deal with this by performing
+   the adjustment in the signal handler before the raise, so our adjustments
+   may break those front-ends.
+
+   To have it all right, we should either find a way to deal with the signal
+   variants from the macro and convert Java on all targets (ugh), or remove
+   our macro adjustments and update our signal handlers a-la-java way.  The
+   latter option appears the simplest, although some targets have their share
+   of subtleties to account for.  See for instance the syscall(SYS_sigaction)
+   story in libjava/include/i386-signal.h.  */
+
 /***********************************/
 /* __gnat_initialize (AIX Version) */
 /***********************************/
@@ -1051,6 +1096,18 @@ struct Machine_State
 
 static void __gnat_error_handler (int, int, sigcontext_t *);
 
+/* We are not setting the SA_SIGINFO bit in the sigaction flags when
+   connecting that handler, with the effects described in the sigaction
+   man page:
+
+          SA_SIGINFO [...]
+          If cleared and the signal is caught, the first argument is
+          also the signal number but the second argument is the signal
+          code identifying the cause of the signal. The third argument
+          points to a sigcontext_t structure containing the receiving
+         process's context when the signal was delivered.
+*/
+
 static void
 __gnat_error_handler (int sig, int code, sigcontext_t *sc)
 {
@@ -1076,8 +1133,13 @@ __gnat_error_handler (int sig, int code, sigcontext_t *sc)
          exception = &program_error; /* ??? storage_error ??? */
          msg = "SIGSEGV: (Autogrow for file failed)";
        }
-      else if (code == EACCES)
+      else if (code == EACCES || code == EEXIST)
        {
+         /* ??? We handle stack overflows here, some of which do trigger
+                SIGSEGV + EEXIST on Irix 6.5 although EEXIST is not part of
+                the documented valid codes for SEGV in the signal(5) man
+                page.  */
+
          /* ??? Re-add smarts to further verify that we launched
                 the stack into a guard page, not an attempt to
                 write to .text or something */
index b96da453496e5b349a9d61f77ff55b527d88fc81..7ca0e31d7e1b5da859f8ec7e5f3aca94db2d2564 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2003 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2004 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- --
@@ -467,6 +467,22 @@ package body Inline is
          return;
       end if;
 
+      --  If the instance appears within a generic subprogram there is nothing
+      --  to finalize either.
+
+      declare
+         S : Entity_Id;
+      begin
+         S := Scope (Inst);
+         while Present (S) and then S /= Standard_Standard loop
+            if Is_Generic_Subprogram (S) then
+               return;
+            end if;
+
+            S := Scope (S);
+         end loop;
+      end;
+
       Elmt := First_Elmt (To_Clean);
 
       while Present (Elmt) loop
index 7168e69c9a220115ec9f7d342f192eae0a6cc835..c4dd7668d489c894fb8cd313aaf80c6e85c944e5 100644 (file)
@@ -944,7 +944,9 @@ package body Lib.Writ is
       --  First the information for the boolean restrictions
 
       for R in All_Boolean_Restrictions loop
-         if Main_Restrictions.Set (R) then
+         if Main_Restrictions.Set (R)
+           and then not Restriction_Warnings (R)
+         then
             Write_Info_Char ('r');
          elsif Main_Restrictions.Violated (R) then
             Write_Info_Char ('v');
index 1b1af12e77d6f4852ed6adf445e901483c94122d..78c0df49895f67e6742cc8e67e791c3b0db10a0b 100644 (file)
@@ -139,18 +139,17 @@ package body Namet is
 
    begin
       if Debug_Flag_H then
-
          for J in F'Range loop
             F (J) := 0;
          end loop;
 
-         for I in Hash_Index_Type loop
-            if Hash_Table (I) = No_Name then
+         for J in Hash_Index_Type loop
+            if Hash_Table (J) = No_Name then
                F (0) := F (0) + 1;
 
             else
                Write_Str ("Hash_Table (");
-               Write_Int (Int (I));
+               Write_Int (Int (J));
                Write_Str (") has ");
 
                declare
@@ -160,7 +159,7 @@ package body Namet is
 
                begin
                   C := 0;
-                  N := Hash_Table (I);
+                  N := Hash_Table (J);
 
                   while N /= No_Name loop
                      N := Name_Entries.Table (N).Hash_Link;
@@ -177,7 +176,7 @@ package body Namet is
                      F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
                   end if;
 
-                  N := Hash_Table (I);
+                  N := Hash_Table (J);
 
                   while N /= No_Name loop
                      S := Name_Entries.Table (N).Name_Chars_Index;
@@ -196,27 +195,27 @@ package body Namet is
 
          Write_Eol;
 
-         for I in Int range 0 .. Max_Chain_Length loop
-            if F (I) /= 0 then
+         for J in Int range 0 .. Max_Chain_Length loop
+            if F (J) /= 0 then
                Write_Str ("Number of hash chains of length ");
 
-               if I < 10 then
+               if J < 10 then
                   Write_Char (' ');
                end if;
 
-               Write_Int (I);
+               Write_Int (J);
 
-               if I = Max_Chain_Length then
+               if J = Max_Chain_Length then
                   Write_Str (" or greater");
                end if;
 
                Write_Str (" = ");
-               Write_Int (F (I));
+               Write_Int (F (J));
                Write_Eol;
 
-               if I /= 0 then
-                  Nsyms := Nsyms + F (I);
-                  Probes := Probes + F (I) * (1 + I) * 100;
+               if J /= 0 then
+                  Nsyms := Nsyms + F (J);
+                  Probes := Probes + F (J) * (1 + J) * 100;
                end if;
             end if;
          end loop;
@@ -560,6 +559,8 @@ package body Namet is
    -- Get_Name_String --
    ---------------------
 
+   --  Procedure version leaving result in Name_Buffer, length in Name_Len
+
    procedure Get_Name_String (Id : Name_Id) is
       S : Int;
 
@@ -574,6 +575,12 @@ package body Namet is
       end loop;
    end Get_Name_String;
 
+   ---------------------
+   -- Get_Name_String --
+   ---------------------
+
+   --  Function version returning a string
+
    function Get_Name_String (Id : Name_Id) return String is
       S : Int;
 
@@ -656,45 +663,12 @@ package body Namet is
    ----------
 
    function Hash return Hash_Index_Type is
-      subtype Int_0_12 is Int range 0 .. 12;
-      --  Used to avoid when others on case jump below
-
-      Even_Name_Len : Integer;
-      --  Last even numbered position (used for >12 case)
-
    begin
-
-      --  Special test for 12 (rather than counting on a when others for the
-      --  case statement below) avoids some Ada compilers converting the case
-      --  statement into successive jumps.
-
-      --  The case of a name longer than 12 characters is handled by taking
-      --  the first 6 odd numbered characters and the last 6 even numbered
-      --  characters
-
-      if Name_Len > 12 then
-         Even_Name_Len := (Name_Len) / 2 * 2;
-
-         return ((((((((((((
-           Character'Pos (Name_Buffer (01))) * 2 +
-           Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
-           Character'Pos (Name_Buffer (03))) * 2 +
-           Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
-           Character'Pos (Name_Buffer (05))) * 2 +
-           Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
-           Character'Pos (Name_Buffer (07))) * 2 +
-           Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
-           Character'Pos (Name_Buffer (09))) * 2 +
-           Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
-           Character'Pos (Name_Buffer (11))) * 2 +
-           Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
-      end if;
-
       --  For the cases of 1-12 characters, all characters participate in the
       --  hash. The positioning is randomized, with the bias that characters
       --  later on participate fully (i.e. are added towards the right side).
 
-      case Int_0_12 (Name_Len) is
+      case Name_Len is
 
          when 0 =>
             return 0;
@@ -813,6 +787,26 @@ package body Namet is
               Character'Pos (Name_Buffer (10))) * 2 +
               Character'Pos (Name_Buffer (12))) mod Hash_Num;
 
+         --  Names longer than 12 characters are handled by taking the first
+         --  6 odd numbered characters and the last 6 even numbered characters.
+
+         when others => declare
+               Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
+         begin
+            return ((((((((((((
+              Character'Pos (Name_Buffer (01))) * 2 +
+              Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
+              Character'Pos (Name_Buffer (03))) * 2 +
+              Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
+              Character'Pos (Name_Buffer (05))) * 2 +
+              Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
+              Character'Pos (Name_Buffer (07))) * 2 +
+              Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
+              Character'Pos (Name_Buffer (09))) * 2 +
+              Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
+              Character'Pos (Name_Buffer (11))) * 2 +
+              Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
+         end;
       end case;
    end Hash;
 
@@ -821,7 +815,6 @@ package body Namet is
    ----------------
 
    procedure Initialize is
-
    begin
       Name_Chars.Init;
       Name_Entries.Init;
@@ -853,12 +846,20 @@ package body Namet is
    -- Is_Internal_Name --
    ----------------------
 
+   --  Version taking an argument
+
    function Is_Internal_Name (Id : Name_Id) return Boolean is
    begin
       Get_Name_String (Id);
       return Is_Internal_Name;
    end Is_Internal_Name;
 
+   ----------------------
+   -- Is_Internal_Name --
+   ----------------------
+
+   --  Version taking its input from Name_Buffer
+
    function Is_Internal_Name return Boolean is
    begin
       if Name_Buffer (1) = '_'
@@ -1033,8 +1034,8 @@ package body Namet is
 
                S := Name_Entries.Table (New_Id).Name_Chars_Index;
 
-               for I in 1 .. Name_Len loop
-                  if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) then
+               for J in 1 .. Name_Len loop
+                  if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
                      goto No_Match;
                   end if;
                end loop;
@@ -1069,9 +1070,9 @@ package body Namet is
 
          --  Set corresponding string entry in the Name_Chars table
 
-         for I in 1 .. Name_Len loop
+         for J in 1 .. Name_Len loop
             Name_Chars.Increment_Last;
-            Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I);
+            Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
          end loop;
 
          Name_Chars.Increment_Last;
@@ -1149,11 +1150,9 @@ package body Namet is
       if In_Character_Range (C) then
          declare
             CC : constant Character := Get_Character (C);
-
          begin
             if CC in 'a' .. 'z' or else CC in '0' .. '9' then
                Name_Buffer (Name_Len) := CC;
-
             else
                Name_Buffer (Name_Len) := 'U';
                Set_Hex_Chars (Natural (C));
index 2d2b422a0c14515f4b6434b9933c6eed40f412e5..5e3675a1e8cd2230ff60a532a48dd1b51289f7ac 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---           Copyright (C) 1995-2002 Ada Core Technologies, Inc.            --
+--           Copyright (C) 1995-2004 Ada Core Technologies, 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- --
@@ -182,9 +182,9 @@ package body System.HTable is
 
    end Static_HTable;
 
-   --------------------
-   --  Simple_HTable --
-   --------------------
+   -------------------
+   -- Simple_HTable --
+   -------------------
 
    package body Simple_HTable is
 
@@ -221,7 +221,6 @@ package body System.HTable is
 
       function  Get (K : Key) return Element is
          Tmp : constant Elmt_Ptr := Tab.Get (K);
-
       begin
          if Tmp = null then
             return No_Element;
@@ -236,7 +235,6 @@ package body System.HTable is
 
       function Get_First return Element is
          Tmp : constant Elmt_Ptr := Tab.Get_First;
-
       begin
          if Tmp = null then
             return No_Element;
@@ -260,7 +258,6 @@ package body System.HTable is
 
       function Get_Next return Element is
          Tmp : constant Elmt_Ptr := Tab.Get_Next;
-
       begin
          if Tmp = null then
             return No_Element;
@@ -318,7 +315,6 @@ package body System.HTable is
 
       procedure Set (K : Key; E : Element) is
          Tmp : constant Elmt_Ptr := Tab.Get (K);
-
       begin
          if Tmp = null then
             Tab.Set (new Element_Wrapper'(K, E, null));
@@ -348,15 +344,16 @@ package body System.HTable is
       function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
       pragma Import (Intrinsic, Rotate_Left);
 
-      Tmp : Uns := 0;
+      Hash_Value : Uns;
 
    begin
+      Hash_Value := 0;
       for J in Key'Range loop
-         Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
+         Hash_Value := Rotate_Left (Hash_Value, 3) + Character'Pos (Key (J));
       end loop;
 
       return Header_Num'First +
-               Header_Num'Base (Tmp mod Header_Num'Range_Length);
+               Header_Num'Base (Hash_Value mod Header_Num'Range_Length);
    end Hash;
 
 end System.HTable;
index 9eaee3e057f6ed0d06629a74f0261c34e986615b..333bae3a9a70e53e8aec7fcd674589e402a8ab13 100644 (file)
@@ -28,7 +28,6 @@ with Atree;    use Atree;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
-with Elists;   use Elists;
 with Exp_Util; use Exp_Util;
 with Fname;    use Fname;
 with Fname.UF; use Fname.UF;
@@ -77,7 +76,7 @@ package body Sem_Ch10 is
    --  in a limited_with clause. If the package was not previously analyzed
    --  then it also performs a basic decoration of the real entities; this
    --  is required to do not pass non-decorated entities to the back-end.
-   --  Implements Ada0Y (AI-50217).
+   --  Implements Ada 0Y (AI-50217).
 
    procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
    --  Check whether the source for the body of a compilation unit must
@@ -101,7 +100,7 @@ package body Sem_Ch10 is
    --  through a regular with clause. This procedure creates the implicit
    --  limited with_clauses for the parents and loads the corresponding units.
    --  The shadow entities are created when the inserted clause is analyzed.
-   --  Implements Ada0Y (AI-50217).
+   --  Implements Ada 0Y (AI-50217).
 
    procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
    --  When a child unit appears in a context clause, the implicit withs on
@@ -129,11 +128,11 @@ package body Sem_Ch10 is
 
    procedure Install_Limited_Context_Clauses (N : Node_Id);
    --  Subsidiary to Install_Context. Process only limited with_clauses
-   --  for current unit. Implements Ada0Y (AI-50217).
+   --  for current unit. Implements Ada 0Y (AI-50217).
 
    procedure Install_Limited_Withed_Unit (N : Node_Id);
    --  Place shadow entities for a limited_with package in the visibility
-   --  structures for the current compilation. Implements Ada0Y (AI-50217).
+   --  structures for the current compilation. Implements Ada 0Y (AI-50217).
 
    procedure Install_Withed_Unit
      (With_Clause     : Node_Id;
@@ -182,7 +181,7 @@ package body Sem_Ch10 is
 
    procedure Remove_Limited_With_Clause (N : Node_Id);
    --  Remove from visibility the shadow entities introduced for a package
-   --  mentioned in a limited_with clause. Implements Ada0Y (AI-50217).
+   --  mentioned in a limited_with clause. Implements Ada 0Y (AI-50217).
 
    procedure Remove_Parents (Lib_Unit : Node_Id);
    --  Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
@@ -620,7 +619,7 @@ package body Sem_Ch10 is
             Item := First (Context_Items (N));
             while Present (Item) loop
 
-               --  Ada0Y (AI-50217): Do not consider limited-withed units
+               --  Ada 0Y (AI-50217): Do not consider limited-withed units
 
                if Nkind (Item) = N_With_Clause
                   and then not Implicit_With (Item)
@@ -799,8 +798,8 @@ package body Sem_Ch10 is
       --  Loop through context items. This is done is three passes:
       --  a) The first pass analyze non-limited with-clauses.
       --  b) The second pass add implicit limited_with clauses for
-      --     the parents of child units (Ada0Y: AI-50217)
-      --  c) The third pass analyzes limited_with clauses (Ada0Y: AI-50217)
+      --     the parents of child units (Ada 0Y: AI-50217)
+      --  c) The third pass analyzes limited_with clauses (Ada 0Y: AI-50217)
 
       Item := First (Context_Items (N));
       while Present (Item) loop
@@ -1617,7 +1616,7 @@ package body Sem_Ch10 is
 
    begin
       if Limited_Present (N) then
-         --  Ada0Y (AI-50217): Build visibility structures but do not
+         --  Ada 0Y (AI-50217): Build visibility structures but do not
          --  analyze unit
 
          Build_Limited_Views (N);
@@ -3033,7 +3032,6 @@ package body Sem_Ch10 is
          if Nkind (Item) = N_With_Clause
            and then Limited_Present (Item)
          then
-
             Check_Withed_Unit (Item);
 
             if Private_Present (Library_Unit (Item)) then
@@ -3165,7 +3163,7 @@ package body Sem_Ch10 is
 
    procedure Install_Private_With_Clauses (P : Entity_Id) is
       Decl   : constant Node_Id := Unit_Declaration_Node (P);
-      Clause : Node_Id;
+      Item   : Node_Id;
 
    begin
       if Debug_Flag_I then
@@ -3175,15 +3173,20 @@ package body Sem_Ch10 is
       end if;
 
       if Nkind (Parent (Decl)) = N_Compilation_Unit then
-         Clause := First (Context_Items (Parent (Decl)));
-         while Present (Clause) loop
-            if Nkind (Clause) = N_With_Clause
-              and then Private_Present (Clause)
+         Item := First (Context_Items (Parent (Decl)));
+
+         while Present (Item) loop
+            if Nkind (Item) = N_With_Clause
+              and then Private_Present (Item)
             then
-               Install_Withed_Unit (Clause, Private_With_OK => True);
+               if Limited_Present (Item) then
+                  Install_Limited_Withed_Unit (Item);
+               else
+                  Install_Withed_Unit (Item, Private_With_OK => True);
+               end if;
             end if;
 
-            Next (Clause);
+            Next (Item);
          end loop;
       end if;
    end Install_Private_With_Clauses;
@@ -3274,10 +3277,11 @@ package body Sem_Ch10 is
                            Get_Source_Unit (Library_Unit (N));
       P_Unit           : constant Entity_Id := Unit (Library_Unit (N));
       P                : Entity_Id;
-      Lim_Elmt         : Elmt_Id;
-      Lim_Typ          : Entity_Id;
       Is_Child_Package : Boolean := False;
 
+      Lim_Header       : Entity_Id;
+      Lim_Typ          : Entity_Id;
+
       function In_Chain (E : Entity_Id) return Boolean;
       --  Check that the shadow entity is not already in the homonym
       --  chain, for example through a limited_with clause in a parent unit.
@@ -3362,6 +3366,35 @@ package body Sem_Ch10 is
                    or else (Is_Child_Package
                              and then Is_Visible_Child_Unit (P)))
       then
+         --  Ada 0Y (AI-262): Install the private declarations of P
+
+         if Private_Present (N)
+           and then not In_Private_Part (P)
+         then
+            declare
+               Id : Entity_Id;
+            begin
+               Id := First_Private_Entity (P);
+
+               while Present (Id) loop
+                  if not Is_Internal (Id)
+                    and then not Is_Child_Unit (Id)
+                  then
+                     if not In_Chain (Id) then
+                        Set_Homonym (Id, Current_Entity (Id));
+                        Set_Current_Entity (Id);
+                     end if;
+
+                     Set_Is_Immediately_Visible (Id);
+                  end if;
+
+                  Next_Entity (Id);
+               end loop;
+
+               Set_In_Private_Part (P);
+            end;
+         end if;
+
          return;
       end if;
 
@@ -3430,12 +3463,17 @@ package body Sem_Ch10 is
 
       Set_Is_Immediately_Visible (P);
 
-      --  Install each incomplete view
+      --  Install each incomplete view. The first element of the limited view
+      --  is a header (an E_Package entity) that is used to reference the first
+      --  shadow entity in the private part of the package
+
+      Lim_Header := Limited_View (P);
+      Lim_Typ    := First_Entity (Lim_Header);
 
-      Lim_Elmt   := First_Elmt (Limited_Views (P));
+      while Present (Lim_Typ) loop
 
-      while Present (Lim_Elmt) loop
-         Lim_Typ  := Node (Lim_Elmt);
+         exit when not Private_Present (N)
+                        and then Lim_Typ = First_Private_Entity (Lim_Header);
 
          if not In_Chain (Lim_Typ) then
             Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
@@ -3446,10 +3484,9 @@ package body Sem_Ch10 is
                Write_Name (Chars (Lim_Typ));
                Write_Eol;
             end if;
-
          end if;
 
-         Next_Elmt (Lim_Elmt);
+         Next_Entity (Lim_Typ);
       end loop;
 
       --  The context clause has installed a limited-view, mark it
@@ -3643,9 +3680,13 @@ package body Sem_Ch10 is
       Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
       P    : constant Entity_Id        := Cunit_Entity (Unum);
 
-      Spec        : Node_Id;         --  To denote a package specification
-      Lim_Typ     : Entity_Id;       --  To denote shadow entities.
-      Comp_Typ    : Entity_Id;       --  To denote real entities.
+      Spec        : Node_Id;            --  To denote a package specification
+      Lim_Typ     : Entity_Id;          --  To denote shadow entities
+      Comp_Typ    : Entity_Id;          --  To denote real entities
+
+      Lim_Header  : Entity_Id;          --  Package entity
+      Last_Lim_E  : Entity_Id := Empty; --  Last limited entity built
+      Last_Pub_Lim_E : Entity_Id;       --  To set the first private entity
 
       procedure Decorate_Incomplete_Type
         (E    : Entity_Id;
@@ -3665,7 +3706,9 @@ package body Sem_Ch10 is
       --  Set basic attributes of tagged type T, including its class_wide type.
       --  The parameters Loc, Scope are used to decorate the class_wide type.
 
-      procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id);
+      procedure Build_Chain
+        (Scope      : Entity_Id;
+         First_Decl : Node_Id);
       --  Construct list of shadow entities and attach it to entity of
       --  package that is mentioned in a limited_with clause.
 
@@ -3673,8 +3716,8 @@ package body Sem_Ch10 is
         (Kind       : Entity_Kind;
          Sloc_Value : Source_Ptr;
          Id_Char    : Character) return Entity_Id;
-      --  This function is similar to New_Internal_Entity, except that the
-      --  entity is not added to the scope's list of entities.
+      --  Build a new internal entity and append it to the list of shadow
+      --  entities available through the limited-header
 
       ------------------------------
       -- Decorate_Incomplete_Type --
@@ -3685,13 +3728,13 @@ package body Sem_Ch10 is
          Scop : Entity_Id)
       is
       begin
-         Set_Ekind                     (E, E_Incomplete_Type);
-         Set_Scope                     (E, Scop);
-         Set_Etype                     (E, E);
-         Set_Is_First_Subtype          (E, True);
-         Set_Stored_Constraint         (E, No_Elist);
-         Set_Full_View                 (E, Empty);
-         Init_Size_Align               (E);
+         Set_Ekind             (E, E_Incomplete_Type);
+         Set_Scope             (E, Scop);
+         Set_Etype             (E, E);
+         Set_Is_First_Subtype  (E, True);
+         Set_Stored_Constraint (E, No_Elist);
+         Set_Full_View         (E, Empty);
+         Init_Size_Align       (E);
       end Decorate_Incomplete_Type;
 
       --------------------------
@@ -3725,7 +3768,7 @@ package body Sem_Ch10 is
             Set_Equivalent_Type           (CW, Empty);
             Set_From_With_Type            (CW, From_With_Type (T));
 
-            Set_Class_Wide_Type (T, CW);
+            Set_Class_Wide_Type           (T, CW);
          end if;
       end Decorate_Tagged_Type;
 
@@ -3750,36 +3793,54 @@ package body Sem_Ch10 is
          Sloc_Value : Source_Ptr;
          Id_Char    : Character) return Entity_Id
       is
-         N : constant Entity_Id :=
+         E : constant Entity_Id :=
                Make_Defining_Identifier (Sloc_Value,
                  Chars => New_Internal_Name (Id_Char));
 
       begin
-         Set_Ekind          (N, Kind);
-         Set_Is_Internal    (N, True);
+         Set_Ekind       (E, Kind);
+         Set_Is_Internal (E, True);
 
          if Kind in Type_Kind then
-            Init_Size_Align (N);
+            Init_Size_Align (E);
          end if;
 
-         return N;
+         Append_Entity (E, Lim_Header);
+         Last_Lim_E := E;
+         return E;
       end New_Internal_Shadow_Entity;
 
       -----------------
       -- Build_Chain --
       -----------------
 
-      --  Could use more comments below ???
-
-      procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
+      procedure Build_Chain
+        (Scope         : Entity_Id;
+         First_Decl    : Node_Id)
+      is
          Analyzed_Unit : constant Boolean := Analyzed (Cunit (Unum));
          Is_Tagged     : Boolean;
          Decl          : Node_Id;
 
       begin
-         Decl := First (Visible_Declarations (Spec));
+         Decl := First_Decl;
 
          while Present (Decl) loop
+
+            --  For each library_package_declaration in the environment, there
+            --  is an implicit declaration of a *limited view* of that library
+            --  package. The limited view of a package contains:
+            --
+            --   * For each nested package_declaration, a declaration of the
+            --     limited view of that package, with the same defining-
+            --     program-unit name.
+            --
+            --   * For each type_declaration in the visible part, an incomplete
+            --     type-declaration with the same defining_identifier, whose
+            --     completion is the type_declaration. If the type_declaration
+            --     is tagged, then the incomplete_type_declaration is tagged
+            --     incomplete.
+
             if Nkind (Decl) = N_Full_Type_Declaration then
                Is_Tagged :=
                   Nkind (Type_Definition (Decl)) = N_Record_Definition
@@ -3797,7 +3858,7 @@ package body Sem_Ch10 is
 
                --  Create shadow entity for type
 
-               Lim_Typ  := New_Internal_Shadow_Entity
+               Lim_Typ := New_Internal_Shadow_Entity
                  (Kind       => Ekind (Comp_Typ),
                   Sloc_Value => Sloc (Comp_Typ),
                   Id_Char    => 'Z');
@@ -3813,7 +3874,6 @@ package body Sem_Ch10 is
                end if;
 
                Set_Non_Limited_View (Lim_Typ, Comp_Typ);
-               Append_Elmt (Lim_Typ,  To => Limited_Views (P));
 
             elsif Nkind (Decl) = N_Private_Type_Declaration
               and then Tagged_Present (Decl)
@@ -3836,7 +3896,6 @@ package body Sem_Ch10 is
                Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
 
                Set_Non_Limited_View (Lim_Typ, Comp_Typ);
-               Append_Elmt (Lim_Typ,  To => Limited_Views (P));
 
             elsif Nkind (Decl) = N_Package_Declaration then
 
@@ -3868,9 +3927,9 @@ package body Sem_Ch10 is
                   --  Note: The non_limited_view attribute is not used
                   --  for local packages.
 
-                  Append_Elmt (Lim_Typ,  To => Limited_Views (P));
-
-                  Build_Chain (Spec, Scope => Lim_Typ);
+                  Build_Chain
+                    (Scope      => Lim_Typ,
+                     First_Decl => First (Visible_Declarations (Spec)));
                end;
             end if;
 
@@ -3931,12 +3990,41 @@ package body Sem_Ch10 is
       end if;
 
       Set_Ekind (P, E_Package);
-      Set_Limited_Views     (P, New_Elmt_List);
-      --  Set_Entity (Name (N), P);
 
-      --  Create the auxiliary chain
+      --  Build the header of the limited_view
+
+      Lim_Header := Make_Defining_Identifier (Sloc (N),
+                      Chars => New_Internal_Name (Id_Char => 'Z'));
+      Set_Ekind (Lim_Header, E_Package);
+      Set_Is_Internal (Lim_Header);
+      Set_Limited_View (P, Lim_Header);
+
+      --  Create the auxiliary chain. All the shadow entities are appended
+      --  to the list of entities of the limited-view header
+
+      Build_Chain
+        (Scope      => P,
+         First_Decl => First (Visible_Declarations (Spec)));
+
+      --  Save the last built shadow entity. It is needed later to set the
+      --  reference to the first shadow entity in the private part
+
+      Last_Pub_Lim_E := Last_Lim_E;
+
+      --  Ada 0Y (AI-262): Add the limited view of the private declarations
+      --  Required to give support to limited-private-with clauses
+
+      Build_Chain (Scope      => P,
+                   First_Decl => First (Private_Declarations (Spec)));
+
+      if Last_Pub_Lim_E /= Empty then
+         Set_First_Private_Entity (Lim_Header,
+                                   Next_Entity (Last_Pub_Lim_E));
+      else
+         Set_First_Private_Entity (Lim_Header,
+                                   First_Entity (P));
+      end if;
 
-      Build_Chain (Spec, Scope => P);
       Set_Limited_View_Installed (Spec);
    end Build_Limited_Views;
 
@@ -4065,7 +4153,7 @@ package body Sem_Ch10 is
       Unit_Name : Entity_Id;
 
    begin
-      --  Ada0Y (AI-50217): We remove the context clauses in two phases:
+      --  Ada 0Y (AI-50217): We remove the context clauses in two phases:
       --  limited-views first and regular-views later (to maintain the
       --  stack model).
 
@@ -4082,7 +4170,6 @@ package body Sem_Ch10 is
            and then Limited_View_Installed (Item)
          then
             Remove_Limited_With_Clause (Item);
-
          end if;
 
          Next (Item);
@@ -4131,10 +4218,9 @@ package body Sem_Ch10 is
    --------------------------------
 
    procedure Remove_Limited_With_Clause (N : Node_Id) is
-      P_Unit    : constant Entity_Id := Unit (Library_Unit (N));
-      P         : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
-      Lim_Elmt  : Elmt_Id;
-      Lim_Typ   : Entity_Id;
+      P_Unit     : constant Entity_Id := Unit (Library_Unit (N));
+      P          : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
+      Lim_Typ    : Entity_Id;
 
    begin
       if Nkind (P) = N_Defining_Program_Unit_Name then
@@ -4151,15 +4237,15 @@ package body Sem_Ch10 is
          Write_Eol;
       end if;
 
-      --  Remove all shadow entities from visibility
-
-      Lim_Elmt  := First_Elmt (Limited_Views (P));
+      --  Remove all shadow entities from visibility. The first element of the
+      --  limited view is a header (an E_Package entity) that is used to
+      --  reference the first shadow entity in the private part of the package
 
-      while Present (Lim_Elmt) loop
-         Lim_Typ  := Node (Lim_Elmt);
+      Lim_Typ    := First_Entity (Limited_View (P));
 
+      while Present (Lim_Typ) loop
          Unchain (Lim_Typ);
-         Next_Elmt (Lim_Elmt);
+         Next_Entity (Lim_Typ);
       end loop;
 
       --  Indicate that the limited view of the package is not installed
@@ -4205,7 +4291,6 @@ package body Sem_Ch10 is
                      Write_Name (Chars (Ent));
                      Write_Eol;
                   end if;
-
                end if;
 
                Next_Entity (Ent);
index 88480d8332b5c82376ee76a29174110479bd4c17..109c05b7adadb84dc72b7c42a9dc0de028f24e67 100644 (file)
@@ -2980,7 +2980,7 @@ package body Sem_Ch3 is
          --  types the level of accessibility depends on the enclosing type
          --  declaration
 
-         Set_Scope (Element_Type, T); --  Ada 0Y (AI-230)
+         Set_Scope (Element_Type, Current_Scope); --  Ada 0Y (AI-230)
 
          --  Ada 0Y (AI-254)
 
index 41d23886b166336cac35cf2c264f705b3babffcf..69cc4d097f5bab4338ce5ed2f7d2cbba73a60ecc 100644 (file)
@@ -796,6 +796,7 @@ package body Sem_Ch6 is
 
       procedure Check_Following_Pragma is
          Prag : Node_Id;
+
       begin
          if Front_End_Inlining
            and then Is_List_Member (N)
@@ -817,6 +818,8 @@ package body Sem_Ch6 is
          end if;
       end Check_Following_Pragma;
 
+   --  Start of processing for Analyze_Subprogram_Body
+
    begin
       if Debug_Flag_C then
          Write_Str ("====  Compiling subprogram body ");
index 518179d85875901677bca4df161657eb3b0959b2..2ec768d37165add69f32fb9e352418622a94fe81 100644 (file)
@@ -696,8 +696,10 @@ package body Sem_Ch8 is
 
          Analyze_And_Resolve (Nam, T);
 
-         --  Ada 0Y (AI-230): Renaming of anonymous access-to-constant types
-         --  allowed if and only if the renamed object is access-to-constant
+         --  Ada 0Y (AI-231): "In the case where the type is defined by an
+         --  access_definition, the renamed entity shall be of an access-to-
+         --  constant type if and only if the access_definition defines an
+         --  access-to-constant type" ARM 8.5.1(4)
 
          if Constant_Present (Access_Definition (N))
            and then not Is_Access_Constant (Etype (Nam))
@@ -3525,7 +3527,8 @@ package body Sem_Ch8 is
         and then From_With_Type (P_Name)
       then
          if From_With_Type (Id)
-           or else (Ekind (Id) = E_Package and then From_With_Type (Id))
+           or else Is_Type (Id)
+           or else Ekind (Id) = E_Package
          then
             null;
          else
index afbb68042b6c881f53fe5c52bbfd3af6ff5d2085..d3ee90e982fec8924d4cf47d05ee1eefd5034524 100644 (file)
@@ -3257,7 +3257,8 @@ package body Sem_Prag is
          Val   : Uint;
 
          procedure Set_Warning (R : All_Restrictions);
-         --  If this is a Restriction_Warnings pragma, set warning flag
+         --  If this is a Restriction_Warnings pragma, set warning flag,
+         --  otherwise flag gets cleared.
 
          -----------------
          -- Set_Warning --
@@ -3265,9 +3266,8 @@ package body Sem_Prag is
 
          procedure Set_Warning (R : All_Restrictions) is
          begin
-            if Prag_Id = Pragma_Restriction_Warnings then
-               Restriction_Warnings (R) := True;
-            end if;
+            Restriction_Warnings (R) :=
+              Prag_Id = Pragma_Restriction_Warnings;
          end Set_Warning;
 
       --  Start of processing for Process_Restrictions_Or_Restriction_Warnings
index c9286121ee3c6c9846deb66c5ba6c47444e482e6..b32d4a63f874b85eb32f8ec7312ca264d31c6246 100644 (file)
@@ -273,7 +273,7 @@ gnat_to_gnu (Node_Id gnat_node)
 {
   tree gnu_root;
   bool made_sequence = false;
-    
+
   /* We support the use of this on statements now as a transition
      to full function-at-a-time processing.  So we need to see if anything
      we do generates RTL and returns error_mark_node.  */
@@ -517,14 +517,32 @@ tree_transform (Node_Id gnat_node)
                  && DECL_BY_COMPONENT_PTR_P (gnu_result))))
        {
          int ro = DECL_POINTS_TO_READONLY_P (gnu_result);
+         tree initial;
 
          if (TREE_CODE (gnu_result) == PARM_DECL
              && DECL_BY_COMPONENT_PTR_P (gnu_result))
            gnu_result = convert (build_pointer_type (gnu_result_type),
                                  gnu_result);
 
-         gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
-                                      fold (gnu_result));
+         /* If the object is constant, we try to do the dereference directly
+            through the DECL_INITIAL.  This is actually required in order to
+            get correct aliasing information for renamed objects that are
+            components of non-aliased aggregates, because the type of
+            the renamed object and that of the aggregate don't alias.  */
+         if (TREE_READONLY (gnu_result)
+             && DECL_INITIAL (gnu_result)
+             /* Strip possible conversion to reference type.  */
+             && (initial = TREE_CODE (DECL_INITIAL (gnu_result)) == NOP_EXPR
+                           ? TREE_OPERAND (DECL_INITIAL (gnu_result), 0)
+                           : DECL_INITIAL (gnu_result), 1)
+             && TREE_CODE (initial) == ADDR_EXPR
+             && (TREE_CODE (TREE_OPERAND (initial, 0)) == ARRAY_REF
+                 || TREE_CODE (TREE_OPERAND (initial, 0)) == COMPONENT_REF))
+           gnu_result = TREE_OPERAND (initial, 0);
+         else
+           gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
+                                        fold (gnu_result));
+
          TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result) = ro;
        }
 
@@ -4373,7 +4391,7 @@ end_block_stmt ()
 
   return gnu_retval;
 }
-   
+
 /* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements.  */
 
 static tree
@@ -4394,7 +4412,7 @@ build_block_stmt (List_Id gnat_list)
 
   gnu_result = end_block_stmt ();
   return TREE_CODE (gnu_result) == NULL_STMT ? NULL_TREE : gnu_result;
-} 
+}
 
 /* Build an EXPR_STMT to evaluate INSNS.  Use Sloc from GNAT_NODE.   */
 
@@ -4523,7 +4541,7 @@ gnat_expand_stmt (tree gnu_stmt)
          }
       break;
 
-    default: 
+    default:
      abort ();
     }
 }