diff options
| -rw-r--r-- | gcc/ada/5qsystem.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/ChangeLog | 96 | ||||
| -rw-r--r-- | gcc/ada/Makefile.in | 3 | ||||
| -rw-r--r-- | gcc/ada/a-numaux-x86.adb | 286 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 2 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 21 | ||||
| -rw-r--r-- | gcc/ada/exp_dbug.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 30 | ||||
| -rw-r--r-- | gcc/ada/init.c | 64 | ||||
| -rw-r--r-- | gcc/ada/inline.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/namet.adb | 111 | ||||
| -rw-r--r-- | gcc/ada/s-htable.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 229 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/trans.c | 30 |
20 files changed, 630 insertions, 329 deletions
diff --git a/gcc/ada/5qsystem.ads b/gcc/ada/5qsystem.ads index c8b94936ded..9052e2b16bb 100644 --- a/gcc/ada/5qsystem.ads +++ b/gcc/ada/5qsystem.ads @@ -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; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 126ecae5d0c..a8a95d1b1b8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index a094a82830e..79d404516e7 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -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))) \ diff --git a/gcc/ada/a-numaux-x86.adb b/gcc/ada/a-numaux-x86.adb index a13733305a1..b11867036f2 100644 --- a/gcc/ada/a-numaux-x86.adb +++ b/gcc/ada/a-numaux-x86.adb @@ -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; diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 7b8813ab6ee..92573fd46d5 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -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) { diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index b2ad23f4da1..df32596a942 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6487a22012e..3b5c5bc033b 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 080e8661564..0abca3055ca 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -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 diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 1a30c465a55..c75882bc78c 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -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 diff --git a/gcc/ada/init.c b/gcc/ada/init.c index b27e059ed9d..9d79b6c3c0e 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -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 */ diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index b96da453496..7ca0e31d7e1 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -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 diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 7168e69c9a2..c4dd7668d48 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -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'); diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 1b1af12e77d..78c0df49895 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -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)); diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index 2d2b422a0c1..5e3675a1e8c 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -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; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 9eaee3e057f..333bae3a9a7 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -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); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 88480d8332b..109c05b7ada 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 41d23886b16..69cc4d097f5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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 "); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 518179d8587..2ec768d3716 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index afbb68042b6..d3ee90e982f 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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 diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c index c9286121ee3..b32d4a63f87 100644 --- a/gcc/ada/trans.c +++ b/gcc/ada/trans.c @@ -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 (); } } |