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;
+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
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=
# 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))) \
-- 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- --
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 --
-- 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);
-- 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 --
-- 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;
----------
return Result;
end Sqrt;
- ---------------------------------
- -- Other Elementary Functions --
- ---------------------------------
+ --------------------------------
+ -- Other Elementary Functions --
+ --------------------------------
-- These are built using the previously implemented basic functions
function Acos (X : Double) return Double is
Result : Double;
+
begin
Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
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
---------
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;
function Logarithmic_Pow (X, Y : Double) return Double is
Result : Double;
-
begin
Asm (Template => "" -- X : Y
& "fyl2x " & NL -- Y * Log2 (X)
Inputs =>
(Double'Asm_Input ("0", X),
Double'Asm_Input ("u", Y)));
-
return Result;
end Logarithmic_Pow;
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;
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
elsif Exp_High /= Abs_Y then
Exp_Low := Abs_Y - Exp_High;
-
Factor := 1.0;
if Exp_Low /= 0.0 then
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;
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;
if abs X < 25.0 then
return (Exp (X) - Exp (-X)) / 2.0;
-
else
return Exp (X) / 2.0;
end if;
-
end Sinh;
----------
if abs X < 22.0 then
return (Exp (X) + Exp (-X)) / 2.0;
-
else
return Exp (X) / 2.0;
end if;
-
end Cosh;
----------
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 ----------- = --------
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;
return NULL;
#else
- struct dirent *dirent = readdir (dirp);
+ struct dirent *dirent = (struct dirent *) readdir (dirp);
if (dirent != NULL)
{
-- Inner_Instances Elist23
-- Enum_Pos_To_Rep Node23
-- Packed_Array_Type Node23
- -- Limited_Views Elist23
+ -- Limited_View Node23
-- Privals_Chain Elist23
-- Protected_Operation Node23
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
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
-- 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
-- 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)
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;
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);
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);
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);
-- __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
* Exception Handling Control::
* Units to Sources Mapping Files::
* Integrated Preprocessing::
+* Code Generation Control::
@ifset vms
* Return Codes::
@end ifset
@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
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) */
/***********************************/
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)
{
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 */
-- --
-- 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- --
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
-- 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');
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
begin
C := 0;
- N := Hash_Table (I);
+ N := Hash_Table (J);
while N /= No_Name loop
N := Name_Entries.Table (N).Hash_Link;
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;
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;
-- Get_Name_String --
---------------------
+ -- Procedure version leaving result in Name_Buffer, length in Name_Len
+
procedure Get_Name_String (Id : Name_Id) is
S : Int;
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;
----------
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;
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;
----------------
procedure Initialize is
-
begin
Name_Chars.Init;
Name_Entries.Init;
-- 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) = '_'
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;
-- 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;
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));
-- --
-- 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- --
end Static_HTable;
- --------------------
- -- Simple_HTable --
- --------------------
+ -------------------
+ -- Simple_HTable --
+ -------------------
package body Simple_HTable is
function Get (K : Key) return Element is
Tmp : constant Elmt_Ptr := Tab.Get (K);
-
begin
if Tmp = null then
return No_Element;
function Get_First return Element is
Tmp : constant Elmt_Ptr := Tab.Get_First;
-
begin
if Tmp = null then
return No_Element;
function Get_Next return Element is
Tmp : constant Elmt_Ptr := Tab.Get_Next;
-
begin
if Tmp = null then
return No_Element;
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));
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;
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;
-- 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
-- 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
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;
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
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)
-- 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
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);
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
then
-
Check_Withed_Unit (Item);
if Private_Present (Library_Unit (Item)) then
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
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;
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.
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;
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));
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
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;
-- 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.
(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 --
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;
--------------------------
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;
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
-- 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');
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)
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
-- 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;
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;
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).
and then Limited_View_Installed (Item)
then
Remove_Limited_With_Clause (Item);
-
end if;
Next (Item);
--------------------------------
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
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
Write_Name (Chars (Ent));
Write_Eol;
end if;
-
end if;
Next_Entity (Ent);
-- 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)
procedure Check_Following_Pragma is
Prag : Node_Id;
+
begin
if Front_End_Inlining
and then Is_List_Member (N)
end if;
end Check_Following_Pragma;
+ -- Start of processing for Analyze_Subprogram_Body
+
begin
if Debug_Flag_C then
Write_Str ("==== Compiling subprogram body ");
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))
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
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 --
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
{
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. */
&& 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;
}
return gnu_retval;
}
-
+
/* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */
static tree
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. */
}
break;
- default:
+ default:
abort ();
}
}
projects / gcc.git / commitdiff