+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;
projects / gcc.git / commitdiff