* sem_dist.adb, exp_dist.adb: When constructing a RAS value for a local
subprogram for which no pragma All_Calls_Remote applies, store the
address of the real subprogram in the underlying record type, so local
dereferences do not go through the PCS.
2004-04-26 Robert Dewar <dewar@gnat.com>
* i-c.ads: Add some type qualifications to avoid ambiguities when
compiling with s-auxdec.ads and a non-private address type.
2004-04-26 Arnaud Charlet <charlet@act-europe.fr>
* Makefile.rtl: Fix error in previous check-in:
Add s-addope.o to non tasking object list (rather than tasking object
list).
2004-04-26 Javier Miranda <miranda@gnat.com>
* sem_aggr.adb: Fix typo in comments
(Resolve_Aggr_Expr): Propagate the type to the nested aggregate.
Required to check the null-exclusion attribute.
* sem_attr.adb (Resolve_Attribute): Check the accessibility level in
case of anonymous access types in record and array components. For a
component definition the level is the same of the enclosing composite
type.
* sem_ch3.adb (Analyze_Component_Declaration): In case of components
that are anonymous access types the level of accessibility depends on
the enclosing type declaration. In order to have this information, set
the scope of the anonymous access type to the enclosing record type
declaration.
(Array_Type_Declaration): In case of components that are anonymous
access types the level of accessibility depends on the enclosing type
declaration. In order to have this information, set the scope of the
anonymous access type to the enclosing array type declaration.
* sem_ch3.adb (Array_Type_Declaration): Set the scope of the anonymous
access type.
* sem_ch8.adb (Analyze_Object_Renaming): Add check to verify that
renaming of anonymous access-to-constant types allowed if and only if
the renamed object is access-to-constant.
* sem_util.adb (Type_Access_Level): In case of anonymous access types
that are component_definition or discriminants of a nonlimited type,
the level is the same as that of the enclosing component type.
2004-04-26 Sergey Rybin <rybin@act-europe.fr>
* sem_elim.adb: Some minor code reorganization from code reading. Fix
misprint in the function name (File_Name_Match).
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@81186
138bc75d-0d04-0410-961f-
82ee72b054a4
+2004-04-26 Thomas Quinot <quinot@act-europe.fr>
+
+ * sem_dist.adb, exp_dist.adb: When constructing a RAS value for a local
+ subprogram for which no pragma All_Calls_Remote applies, store the
+ address of the real subprogram in the underlying record type, so local
+ dereferences do not go through the PCS.
+
+2004-04-26 Robert Dewar <dewar@gnat.com>
+
+ * i-c.ads: Add some type qualifications to avoid ambiguities when
+ compiling with s-auxdec.ads and a non-private address type.
+
+2004-04-26 Arnaud Charlet <charlet@act-europe.fr>
+
+ * Makefile.rtl: Fix error in previous check-in:
+ Add s-addope.o to non tasking object list (rather than tasking object
+ list).
+
+2004-04-26 Javier Miranda <miranda@gnat.com>
+
+ * sem_aggr.adb: Fix typo in comments
+ (Resolve_Aggr_Expr): Propagate the type to the nested aggregate.
+ Required to check the null-exclusion attribute.
+
+ * sem_attr.adb (Resolve_Attribute): Check the accessibility level in
+ case of anonymous access types in record and array components. For a
+ component definition the level is the same of the enclosing composite
+ type.
+
+ * sem_ch3.adb (Analyze_Component_Declaration): In case of components
+ that are anonymous access types the level of accessibility depends on
+ the enclosing type declaration. In order to have this information, set
+ the scope of the anonymous access type to the enclosing record type
+ declaration.
+ (Array_Type_Declaration): In case of components that are anonymous
+ access types the level of accessibility depends on the enclosing type
+ declaration. In order to have this information, set the scope of the
+ anonymous access type to the enclosing array type declaration.
+
+ * sem_ch3.adb (Array_Type_Declaration): Set the scope of the anonymous
+ access type.
+
+ * sem_ch8.adb (Analyze_Object_Renaming): Add check to verify that
+ renaming of anonymous access-to-constant types allowed if and only if
+ the renamed object is access-to-constant.
+
+ * sem_util.adb (Type_Access_Level): In case of anonymous access types
+ that are component_definition or discriminants of a nonlimited type,
+ the level is the same as that of the enclosing component type.
+
+2004-04-26 Sergey Rybin <rybin@act-europe.fr>
+
+ * sem_elim.adb: Some minor code reorganization from code reading. Fix
+ misprint in the function name (File_Name_Match).
+
2004-04-23 Laurent GUERBY <laurent@guerby.net>
* Makefile.in: Remove RANLIB_TEST, use -$(RANLIB) including after
g-semaph$(objext) \
g-signal$(objext) \
g-thread$(objext) \
- s-addope$(objext) \
s-asthan$(objext) \
s-inmaop$(objext) \
s-interr$(objext) \
ioexcept$(objext) \
machcode$(objext) \
s-addima$(objext) \
+ s-addope$(objext) \
s-arit64$(objext) \
s-assert$(objext) \
s-atacco$(objext) \
Proc_Decls : constant List_Id := New_List;
Proc_Statements : constant List_Id := New_List;
- Proc_Spec : Node_Id;
-
- Proc : Node_Id;
-
- Param : Node_Id;
- Package_Name : Node_Id;
- Subp_Id : Node_Id;
- Asynch_P : Node_Id;
- Return_Value : Node_Id;
+ Proc_Spec : Node_Id;
+ Proc : Node_Id;
+ Local_Addr : Entity_Id;
+ Package_Name : Entity_Id;
+ Subp_Id : Entity_Id;
+ Asynch_P : Entity_Id;
+ Origin : Entity_Id;
+ Return_Value : Entity_Id;
All_Calls_Remote : Entity_Id;
-- True if an All_Calls_Remote pragma applies to the RCI unit
Loc : constant Source_Ptr := Sloc (N);
- procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id);
- -- Set a field name for the return value
+ function Set_Field
+ (Field_Name : Name_Id;
+ Value : Node_Id) return Node_Id;
+ -- Construct an assignment that sets the named component in the
+ -- returned record
- procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id)
+ ---------------
+ -- Set_Field --
+ ---------------
+
+ function Set_Field
+ (Field_Name : Name_Id;
+ Value : Node_Id) return Node_Id
is
begin
- Append_To (Proc_Statements,
+ return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Return_Value, Loc),
Selector_Name => Make_Identifier (Loc, Field_Name)),
- Expression => Value));
+ Expression => Value);
end Set_Field;
-- Start of processing for Add_RAS_Access_Attribute
begin
- Param := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
- Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
- Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Local_Addr := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
+ Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
+ Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+ Origin := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
All_Calls_Remote :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
-- Create the object which will be returned of type Fat_Type
- Append_To (Proc_Decls,
+ Append_List_To (Proc_Decls, New_List (
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Origin,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Package_Name, Loc)))),
+
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Value,
Object_Definition =>
- New_Occurrence_Of (Fat_Type, Loc)));
+ New_Occurrence_Of (Fat_Type, Loc))));
-- Initialize the fields of the record type with the appropriate data
- Set_Field (Name_Ras,
- OK_Convert_To (RTE (RE_Unsigned_64), New_Occurrence_Of (Param, Loc)));
+ Append_List_To (Proc_Statements, New_List (
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Not (Loc,
+ New_Occurrence_Of (All_Calls_Remote, Loc)),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Origin, Loc),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ New_Occurrence_Of (
+ RTE (RE_Get_Local_Partition_Id), Loc)))),
+
+ Then_Statements => New_List (
+ Set_Field (Name_Ras,
+ OK_Convert_To (RTE (RE_Unsigned_64),
+ New_Occurrence_Of (Local_Addr, Loc)))),
+
+ Else_Statements => New_List (
+ Set_Field (Name_Ras,
+ Make_Integer_Literal (Loc, Uint_0)))),
+
+ Set_Field (Name_Origin,
+ Unchecked_Convert_To (Standard_Integer,
+ New_Occurrence_Of (Origin, Loc))),
- Set_Field (Name_Origin,
- Unchecked_Convert_To (Standard_Integer,
+ Set_Field (Name_Receiver,
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
+ New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Package_Name, Loc)))));
-
- Set_Field (Name_Receiver,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Package_Name, Loc))));
+ New_Occurrence_Of (Package_Name, Loc)))),
- Set_Field (Name_Subp_Id,
- New_Occurrence_Of (Subp_Id, Loc));
+ Set_Field (Name_Subp_Id,
+ New_Occurrence_Of (Subp_Id, Loc)),
- Set_Field (Name_Async,
- New_Occurrence_Of (Asynch_P, Loc));
+ Set_Field (Name_Async,
+ New_Occurrence_Of (Asynch_P, Loc))));
-- Return the newly created value
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier => Param,
+ Defining_Identifier => Local_Addr,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- Signed and Unsigned Integers. Note that in GNAT, we have ensured that
-- the standard predefined Ada types correspond to the standard C types
+ -- Note: the Integer qualifications used in the declaration of type long
+ -- avoid ambiguities when compiling in the presence of s-auxdec.ads and
+ -- a non-private system.address type.
+
type int is new Integer;
type short is new Short_Integer;
- type long is range -(2 ** (System.Parameters.long_bits - 1))
- .. +(2 ** (System.Parameters.long_bits - 1)) - 1;
+ type long is range -(2 ** (System.Parameters.long_bits - Integer'(1)))
+ .. +(2 ** (System.Parameters.long_bits - Integer'(1))) - 1;
type signed_char is range SCHAR_MIN .. SCHAR_MAX;
for signed_char'Size use CHAR_BIT;
subtype plain_char is unsigned_char; -- ??? should be parametrized
+ -- Note: the Integer qualifications used in the declaration of ptrdiff_t
+ -- avoid ambiguities when compiling in the presence of s-auxdec.ads and
+ -- a non-private system.address type.
+
type ptrdiff_t is
- range -(2 ** (Standard'Address_Size - 1)) ..
- +(2 ** (Standard'Address_Size - 1) - 1);
+ range -(2 ** (Standard'Address_Size - Integer'(1))) ..
+ +(2 ** (Standard'Address_Size - Integer'(1)) - 1);
type size_t is mod 2 ** Standard'Address_Size;
Aggr_Typ : constant Entity_Id := Etype (Typ);
-- This is the unconstrained array type, which is the type
- -- against which the aggregate is to be resoved. Typ itself
+ -- against which the aggregate is to be resolved. Typ itself
-- is the array type of the context which may not be the same
-- subtype as the subtype for the final aggregate.
-- formal parameter. Consequently we also need to test for
-- N_Procedure_Call_Statement or N_Function_Call.
- Set_Etype (N, Aggr_Typ); -- may be overridden later on.
+ Set_Etype (N, Aggr_Typ); -- may be overridden later on
-- Ada 0Y (AI-231): Propagate the null_exclusion attribute to the
-- components of the array aggregate
end if;
end if;
+ -- Ada 0Y (AI-231): Propagate the type to the nested aggregate.
+ -- Required to check the null-exclusion attribute (if present).
+ -- This value may be overridden later on.
+
+ Set_Etype (Expr, Etype (N));
+
Resolution_OK := Resolve_Array_Aggregate
(Expr, Nxt_Ind, Nxt_Ind_Constr, Component_Typ, Others_Allowed);
or else
Attr_Id = Attribute_Unchecked_Access)
and then (Ekind (Btyp) = E_General_Access_Type
- or else Ekind (Btyp) = E_Anonymous_Access_Type)
+ or else Ekind (Btyp) = E_Anonymous_Access_Type)
then
+ -- Ada 0Y (AI-230): Check the accessibility of anonymous access
+ -- types in record and array components. For a component defini
+ -- tion the level is the same of the enclosing composite type.
+
+ if Extensions_Allowed
+ and then Ekind (Btyp) = E_Anonymous_Access_Type
+ and then (Is_Array_Type (Scope (Btyp))
+ or else Ekind (Scope (Btyp)) = E_Record_Type)
+ and then Object_Access_Level (P)
+ > Type_Access_Level (Btyp)
+ then
+ -- In an instance, this is a runtime check, but one we
+ -- know will fail, so generate an appropriate warning.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?non-local pointer cannot point to local object", P);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", P);
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Typ);
+ else
+ Error_Msg_N
+ ("non-local pointer cannot point to local object", P);
+ end if;
+ end if;
+
if Is_Dependent_Component_Of_Mutable_Object (P) then
Error_Msg_N
("illegal attribute for discriminant-dependent component",
(Related_Nod => N,
N => Access_Definition (Component_Definition (N)));
+ -- Ada 0Y (AI-230): In case of components that are anonymous access
+ -- types the level of accessibility depends on the enclosing type
+ -- declaration
+
+ Set_Scope (T, Current_Scope); -- Ada 0Y (AI-230)
+
-- Ada 0Y (AI-254)
if Present (Access_To_Subprogram_Definition
(Related_Nod => Related_Id,
N => Access_Definition (Component_Def));
+ -- Ada 0Y (AI-230): In case of components that are anonymous access
+ -- types the level of accessibility depends on the enclosing type
+ -- declaration
+
+ Set_Scope (Element_Type, T); -- Ada 0Y (AI-230)
+
-- Ada 0Y (AI-254)
declare
elsif Present (Access_Definition (N)) then
- if Null_Exclusion_Present (Access_Definition (N)) then
- Error_Msg_N ("(Ada 0Y): null-excluding attribute ignored "
- & "('R'M 8.5.1(6))?", N);
- Set_Null_Exclusion_Present (Access_Definition (N), False);
- end if;
-
T := Access_Definition
(Related_Nod => N,
N => Access_Definition (N));
+
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
+
+ if Constant_Present (Access_Definition (N))
+ and then not Is_Access_Constant (Etype (Nam))
+ then
+ Error_Msg_N ("(Ada 0Y): the renamed object is not "
+ & "access-to-constant ('R'M 8.5.1(6))", N);
+
+ elsif Null_Exclusion_Present (Access_Definition (N)) then
+ Error_Msg_N ("(Ada 0Y): null-excluding attribute ignored "
+ & "('R'M 8.5.1(6))?", N);
+ end if;
else
pragma Assert (False);
null;
Async_E : Entity_Id;
All_Calls_Remote_E : Entity_Id;
Attribute_Subp : Entity_Id;
- Parameter : Node_Id;
+ Local_Addr : Node_Id;
begin
-- Check if we have to expand the access attribute
All_Calls_Remote_E := Standard_False;
end if;
- Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
+ Local_Addr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Remote_Subp, Loc),
+ Attribute_Name => Name_Address);
Tick_Access_Conv_Call :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Attribute_Subp, Loc),
Parameter_Associations =>
New_List (
- Parameter,
+ Local_Addr,
Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
Build_Subprogram_Id (Loc, Remote_Subp),
New_Occurrence_Of (Async_E, Loc),
P : Source_Ptr;
Sindex : Source_File_Index;
- function File_Mame_Match return Boolean;
+ function File_Name_Match return Boolean;
-- This function is supposed to be called when Idx points
-- to the beginning of the new file name, and Name_Buffer
-- is set to contain the name of the proper source file
end if;
end Different_Trace_Lengths;
- function File_Mame_Match return Boolean is
- Tmp_Idx : Positive := 1;
- End_Idx : Positive := 1;
- -- Initializations are to stop warnings
+ ---------------------
+ -- File_Name_Match --
+ ---------------------
- -- But are warnings possibly valid ???
- -- Why are loops below guaranteed to exit ???
+ function File_Name_Match return Boolean is
+ Tmp_Idx : Natural;
+ End_Idx : Natural;
begin
if Idx = 0 then
return False;
end if;
- for J in Idx .. Last loop
- if Sloc_Trace (J) = ':' then
- Tmp_Idx := J - 1;
+ -- Find first colon. If no colon, then return False.
+ -- If there is a colon, Tmp_Idx is set to point just
+ -- before the colon.
+
+ Tmp_Idx := Idx - 1;
+ loop
+ if Tmp_Idx >= Last then
+ return False;
+ elsif Sloc_Trace (Tmp_Idx + 1) = ':' then
exit;
+ else
+ Tmp_Idx := Tmp_Idx + 1;
end if;
end loop;
- for J in reverse Idx .. Tmp_Idx loop
- if Sloc_Trace (J) /= ' ' then
- End_Idx := J;
+ -- Find last non-space before this colon. If there
+ -- is no no space character before this colon, then
+ -- return False. Otherwise, End_Idx set to point to
+ -- this non-space character.
+
+ End_Idx := Tmp_Idx;
+ loop
+ if End_Idx < Idx then
+ return False;
+ elsif Sloc_Trace (End_Idx) /= ' ' then
exit;
+ else
+ End_Idx := End_Idx - 1;
end if;
end loop;
+ -- Now see if file name matches what is in Name_Buffer
+ -- and if so, step Idx past it and return True. If the
+ -- name does not match, return False.
+
if Sloc_Trace (Idx .. End_Idx) =
Name_Buffer (1 .. Name_Len)
then
Idx := Tmp_Idx + 2;
-
Idx := Skip_Spaces;
-
return True;
else
return False;
end if;
- end File_Mame_Match;
+ end File_Name_Match;
--------------------
-- Line_Num_Match --
Idx := Skip_Spaces;
while Idx > 0 loop
- if not File_Mame_Match then
+ if not File_Name_Match then
goto Continue;
elsif not Line_Num_Match then
goto Continue;
-- declared at the library level to ensure that names such as
-- X.all'access don't fail static accessibility checks.
+ -- Ada 0Y (AI-230): In case of anonymous access types that are
+ -- component_definition or discriminants of a nonlimited type,
+ -- the level is the same as that of the enclosing component type.
+
Btyp := Base_Type (Typ);
if Ekind (Btyp) in Access_Kind then
- if Ekind (Btyp) = E_Anonymous_Access_Type then
+ if Ekind (Btyp) = E_Anonymous_Access_Type
+ and then not Is_Array_Type (Scope (Btyp)) -- Ada 0Y (AI-230)
+ and then Ekind (Scope (Btyp)) /= E_Record_Type -- Ada 0Y (AI-230)
+ then
return Scope_Depth (Standard_Standard);
end if;
OSDN Git Service
