From 0fb2ea01912a8a8859cb53caa6a7e33b9b8c9333 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 24 May 2004 17:19:11 +0200 Subject: [PATCH] [multiple changes] 2004-05-24 Geert Bosch * 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 * adaint.c (__gnat_readdir): Cast CRTL function retun value to avoid gcc error on 32/64 bit VMS. 2004-05-24 Olivier Hainque * 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 * 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 * 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 * 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 * 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 (tree_transform) : Do the dereference directly through the DECL_INITIAL for renamed variables. From-SVN: r82205 --- gcc/ada/5qsystem.ads | 8 ++ gcc/ada/ChangeLog | 96 +++++++++++++ gcc/ada/Makefile.in | 3 +- gcc/ada/a-numaux-x86.adb | 286 ++++++++++++++++++--------------------- gcc/ada/adaint.c | 2 +- gcc/ada/einfo.adb | 14 +- gcc/ada/einfo.ads | 21 +-- gcc/ada/exp_dbug.ads | 2 +- gcc/ada/gnat_ugn.texi | 30 ++++ gcc/ada/init.c | 64 ++++++++- gcc/ada/inline.adb | 18 ++- gcc/ada/lib-writ.adb | 4 +- gcc/ada/namet.adb | 111 ++++++++------- gcc/ada/s-htable.adb | 19 ++- gcc/ada/sem_ch10.adb | 229 +++++++++++++++++++++---------- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 3 + gcc/ada/sem_ch8.adb | 9 +- gcc/ada/sem_prag.adb | 8 +- 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 + + * 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 + + * adaint.c (__gnat_readdir): Cast CRTL function retun value to avoid + gcc error on 32/64 bit VMS. + +2004-05-24 Olivier Hainque + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + (tree_transform) : Do the dereference directly through + the DECL_INITIAL for renamed variables. + 2004-05-24 Arnaud Charlet * 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 - -- 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 (); } } -- 2.30.2