-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Attr; use Sem_Attr;
with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
-- that no component is declared with a nonstatic default value.
-- If a nonstatic default exists, report an error on Obj_Decl.
- -- Iterate through the component list of a record definition, check
- -- that no component is declared with a non-static default value.
+ function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
+ -- Return True if entity has attribute definition clauses for Read and
+ -- Write attributes that are visible at some place.
+
+ function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
+ -- Returns true if the entity is a type whose full view is a non-remote
+ -- access type, for the purpose of enforcing E.2.2(8) rules.
+
+ function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean;
+ -- Return true if Typ or the type of any of its subcomponents is a non
+ -- remote access type and doesn't have user-defined stream attributes.
- function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean;
- -- Return True if the entity or one of its subcomponents is of an access
- -- type that does not have user-defined Read and Write attributes visible
- -- at any place.
+ function No_External_Streaming (E : Entity_Id) return Boolean;
+ -- Return True if the entity or one of its subcomponents does not support
+ -- external streaming.
function In_RCI_Declaration (N : Node_Id) return Boolean;
-- Determines if a declaration is within the visible part of a Remote
-- Determines if current scope is within the declaration of a Remote Types
-- unit, for semantic checking purposes.
- function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
- -- Returns true if the entity is a type whose full view is a non-remote
- -- access type, for the purpose of enforcing E.2.2(8) rules.
-
function In_Shared_Passive_Unit return Boolean;
-- Determines if current scope is within a Shared Passive compilation unit
-- also constraints about the primitive subprograms of the class-wide type.
-- RM E.2 (9, 13, 14)
+ procedure Validate_RACW_Primitive
+ (Subp : Entity_Id;
+ RACW : Entity_Id);
+ -- Check legality of the declaration of primitive Subp of the designated
+ -- type of the given RACW type.
+
---------------------------------------
-- Check_Categorization_Dependencies --
---------------------------------------
end loop;
end Check_Non_Static_Default_Expr;
+ ---------------------------
+ -- Has_Non_Remote_Access --
+ ---------------------------
+
+ function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean is
+ Component : Entity_Id;
+ Comp_Type : Entity_Id;
+ U_Typ : constant Entity_Id := Underlying_Type (Typ);
+ begin
+ if No (U_Typ) then
+ return False;
+
+ elsif Has_Read_Write_Attributes (Typ)
+ or else Has_Read_Write_Attributes (U_Typ)
+ then
+ return False;
+
+ elsif Is_Non_Remote_Access_Type (U_Typ) then
+ return True;
+ end if;
+
+ if Is_Record_Type (U_Typ) then
+ Component := First_Entity (U_Typ);
+ while Present (Component) loop
+ if not Is_Tag (Component) then
+ Comp_Type := Etype (Component);
+
+ if Has_Non_Remote_Access (Comp_Type) then
+ return True;
+ end if;
+ end if;
+
+ Next_Entity (Component);
+ end loop;
+
+ elsif Is_Array_Type (U_Typ) then
+ return Has_Non_Remote_Access (Component_Type (U_Typ));
+
+ end if;
+
+ return False;
+ end Has_Non_Remote_Access;
+
+ -------------------------------
+ -- Has_Read_Write_Attributes --
+ -------------------------------
+
+ function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
+ begin
+ return True
+ and then Has_Stream_Attribute_Definition (E,
+ TSS_Stream_Read, At_Any_Place => True)
+ and then Has_Stream_Attribute_Definition (E,
+ TSS_Stream_Write, At_Any_Place => True);
+ end Has_Read_Write_Attributes;
+
-------------------------------------
-- Has_Stream_Attribute_Definition --
-------------------------------------
and then not Is_Remote_Access_To_Subprogram_Type (U_E);
end Is_Non_Remote_Access_Type;
- ----------------------------------
- -- Missing_Read_Write_Attribute --
- ----------------------------------
-
- function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is
- Component : Entity_Id;
- Component_Type : Entity_Id;
- U_E : constant Entity_Id := Underlying_Type (E);
-
- function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
- -- Return True if entity has attribute definition clauses for Read and
- -- Write attributes that are visible at some place.
-
- -------------------------------
- -- Has_Read_Write_Attributes --
- -------------------------------
-
- function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
- begin
- return True
- and then Has_Stream_Attribute_Definition (E,
- TSS_Stream_Read, At_Any_Place => True)
- and then Has_Stream_Attribute_Definition (E,
- TSS_Stream_Write, At_Any_Place => True);
- end Has_Read_Write_Attributes;
-
- -- Start of processing for Missing_Read_Write_Attributes
+ ---------------------------
+ -- No_External_Streaming --
+ ---------------------------
+ function No_External_Streaming (E : Entity_Id) return Boolean is
+ U_E : constant Entity_Id := Underlying_Type (E);
begin
if No (U_E) then
return False;
- elsif Has_Read_Write_Attributes (E)
- or else Has_Read_Write_Attributes (U_E)
- then
+ elsif Has_Read_Write_Attributes (E) then
+ -- Note: availability of stream attributes is tested on E, not U_E.
+ -- There may be stream attributes defined on U_E that are not visible
+ -- at the place where support of external streaming is tested.
+
return False;
- elsif Is_Non_Remote_Access_Type (U_E) then
+ elsif Has_Non_Remote_Access (U_E) then
return True;
end if;
- if Is_Record_Type (U_E) then
- Component := First_Entity (U_E);
- while Present (Component) loop
- if not Is_Tag (Component) then
- Component_Type := Etype (Component);
-
- if Missing_Read_Write_Attributes (Component_Type) then
- return True;
- end if;
- end if;
-
- Next_Entity (Component);
- end loop;
- end if;
-
- return False;
- end Missing_Read_Write_Attributes;
+ return Is_Limited_Type (E);
+ end No_External_Streaming;
-------------------------------------
-- Set_Categorization_From_Pragmas --
end Validate_Object_Declaration;
- ------------------------------
- -- Validate_RACW_Primitives --
- ------------------------------
+ -----------------------------
+ -- Validate_RACW_Primitive --
+ -----------------------------
- procedure Validate_RACW_Primitives (T : Entity_Id) is
- Desig_Type : Entity_Id;
- Primitive_Subprograms : Elist_Id;
- Subprogram_Elmt : Elmt_Id;
- Subprogram : Entity_Id;
- Param_Spec : Node_Id;
- Param : Entity_Id;
- Param_Type : Entity_Id;
- Rtyp : Node_Id;
+ procedure Validate_RACW_Primitive
+ (Subp : Entity_Id;
+ RACW : Entity_Id)
+ is
+ procedure Illegal_Remote_Subp (Msg : String; N : Node_Id);
+ -- Diagnose illegality on N. If RACW is present, report the error on it
+ -- rather than on N.
- procedure Illegal_RACW (Msg : String; N : Node_Id);
- -- Diagnose that T is illegal because of the given reason, associated
- -- with the location of node N.
+ -------------------------
+ -- Illegal_Remote_Subp --
+ -------------------------
- Illegal_RACW_Message_Issued : Boolean := False;
- -- Set True once Illegal_RACW has been called
+ procedure Illegal_Remote_Subp (Msg : String; N : Node_Id) is
+ begin
+ if Present (RACW) then
+ if not Error_Posted (RACW) then
+ Error_Msg_N
+ ("illegal remote access to class-wide type&", RACW);
+ end if;
- ------------------
- -- Illegal_RACW --
- ------------------
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_NE ("\\" & Msg & " in primitive& #", RACW, Subp);
- procedure Illegal_RACW (Msg : String; N : Node_Id) is
- begin
- if not Illegal_RACW_Message_Issued then
- Error_Msg_N
- ("illegal remote access to class-wide type&", T);
- Illegal_RACW_Message_Issued := True;
+ else
+ Error_Msg_NE (Msg & " in remote subprogram&", N, Subp);
end if;
+ end Illegal_Remote_Subp;
- Error_Msg_Sloc := Sloc (N);
- Error_Msg_N ("\\" & Msg & " in primitive#", T);
- end Illegal_RACW;
+ Rtyp : Entity_Id;
+ Param : Node_Id;
+ Param_Spec : Node_Id;
+ Param_Type : Entity_Id;
- -- Start of processing for Validate_RACW_Primitives
+ -- Start of processing for Validate_RACW_Primitive
begin
- Desig_Type := Etype (Designated_Type (T));
+ -- Check return type
- -- No action needed for concurrent types
+ if Ekind (Subp) = E_Function then
+ Rtyp := Etype (Subp);
- if Is_Concurrent_Type (Desig_Type) then
- return;
- end if;
-
- Primitive_Subprograms := Primitive_Operations (Desig_Type);
+ if Has_Controlling_Result (Subp) then
+ null;
- Subprogram_Elmt := First_Elmt (Primitive_Subprograms);
- while Subprogram_Elmt /= No_Elmt loop
- Subprogram := Node (Subprogram_Elmt);
+ elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
+ Illegal_Remote_Subp ("anonymous access result", Rtyp);
- if Is_Predefined_Dispatching_Operation (Subprogram)
- or else Is_Hidden (Subprogram)
- then
- goto Next_Subprogram;
+ elsif Is_Limited_Type (Rtyp) then
+ if No (TSS (Rtyp, TSS_Stream_Read))
+ or else
+ No (TSS (Rtyp, TSS_Stream_Write))
+ then
+ Illegal_Remote_Subp
+ ("limited return type must have Read and Write attributes",
+ Parent (Subp));
+ Explain_Limited_Type (Rtyp, Parent (Subp));
+
+ -- Check that the return type supports external streaming.
+ -- Note that the language of the standard (E.2.2(14)) does not
+ -- explicitly mention that case, but it really does not make
+ -- sense to return a value containing a local access type.
+
+ elsif No_External_Streaming (Rtyp)
+ and then not Error_Posted (Rtyp)
+ then
+ Illegal_Remote_Subp ("return type containing non-remote access "
+ & "must have Read and Write attributes",
+ Parent (Subp));
+ end if;
end if;
+ end if;
- -- Check return type
+ Param := First_Formal (Subp);
+ while Present (Param) loop
- if Ekind (Subprogram) = E_Function then
- Rtyp := Etype (Subprogram);
+ -- Now find out if this parameter is a controlling parameter
- if Has_Controlling_Result (Subprogram) then
- null;
+ Param_Spec := Parent (Param);
+ Param_Type := Etype (Param);
- elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
- Illegal_RACW ("anonymous access result", Rtyp);
+ if Is_Controlling_Formal (Param) then
- elsif Is_Limited_Type (Rtyp) then
- if No (TSS (Rtyp, TSS_Stream_Read))
- or else
- No (TSS (Rtyp, TSS_Stream_Write))
- then
- Illegal_RACW
- ("limited return type must have Read and Write attributes",
- Parent (Subprogram));
- Explain_Limited_Type (Rtyp, Parent (Subprogram));
-
- -- Check that the return type supports external streaming.
- -- Note that the language of the standard (E.2.2(14)) does not
- -- explicitly mention that case, but it really does not make
- -- sense to return a value containing a local access type.
-
- elsif Missing_Read_Write_Attributes (Rtyp)
- and then not Error_Posted (Rtyp)
- then
- Illegal_RACW ("return type containing non-remote access "
- & "must have Read and Write attributes",
- Parent (Subprogram));
- end if;
+ -- It is a controlling parameter, so specific checks below do not
+ -- apply.
- end if;
- end if;
+ null;
- Param := First_Formal (Subprogram);
- while Present (Param) loop
+ elsif Ekind_In (Param_Type, E_Anonymous_Access_Type,
+ E_Anonymous_Access_Subprogram_Type)
+ then
+ -- From RM E.2.2(14), no anonymous access parameter other than
+ -- controlling ones may be used (because an anonymous access
+ -- type never supports external streaming).
- -- Now find out if this parameter is a controlling parameter
+ Illegal_Remote_Subp
+ ("non-controlling access parameter", Param_Spec);
- Param_Spec := Parent (Param);
- Param_Type := Etype (Param);
+ elsif No_External_Streaming (Param_Type)
+ and then not Error_Posted (Param_Type)
+ then
+ Illegal_Remote_Subp ("formal parameter in remote subprogram must "
+ & "support external streaming", Param_Spec);
+ end if;
- if Is_Controlling_Formal (Param) then
+ -- Check next parameter in this subprogram
- -- It is a controlling parameter, so specific checks below
- -- do not apply.
+ Next_Formal (Param);
+ end loop;
+ end Validate_RACW_Primitive;
- null;
+ ------------------------------
+ -- Validate_RACW_Primitives --
+ ------------------------------
- elsif Ekind_In (Param_Type, E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type)
- then
- -- From RM E.2.2(14), no anonymous access parameter other than
- -- controlling ones may be used (because an anonymous access
- -- type never supports external streaming).
+ procedure Validate_RACW_Primitives (T : Entity_Id) is
+ Desig_Type : Entity_Id;
+ Primitive_Subprograms : Elist_Id;
+ Subprogram_Elmt : Elmt_Id;
+ Subprogram : Entity_Id;
- Illegal_RACW ("non-controlling access parameter", Param_Spec);
+ begin
+ Desig_Type := Etype (Designated_Type (T));
- elsif Is_Limited_Type (Param_Type) then
+ -- No action needed for concurrent types
- -- Not a controlling parameter, so type must have Read and
- -- Write attributes.
+ if Is_Concurrent_Type (Desig_Type) then
+ return;
+ end if;
- if No (TSS (Param_Type, TSS_Stream_Read))
- or else
- No (TSS (Param_Type, TSS_Stream_Write))
- then
- Illegal_RACW
- ("limited formal must have Read and Write attributes",
- Param_Spec);
- Explain_Limited_Type (Param_Type, Param_Spec);
- end if;
+ Primitive_Subprograms := Primitive_Operations (Desig_Type);
- elsif Missing_Read_Write_Attributes (Param_Type)
- and then not Error_Posted (Param_Type)
- then
- Illegal_RACW ("parameter containing non-remote access "
- & "must have Read and Write attributes", Param_Spec);
- end if;
+ Subprogram_Elmt := First_Elmt (Primitive_Subprograms);
+ while Subprogram_Elmt /= No_Elmt loop
+ Subprogram := Node (Subprogram_Elmt);
- -- Check next parameter in this subprogram
+ if Is_Predefined_Dispatching_Operation (Subprogram)
+ or else Is_Hidden (Subprogram)
+ then
+ goto Next_Subprogram;
+ end if;
- Next_Formal (Param);
- end loop;
+ Validate_RACW_Primitive (Subp => Subprogram, RACW => T);
- <<Next_Subprogram>>
- Next_Elmt (Subprogram_Elmt);
+ <<Next_Subprogram>>
+ Next_Elmt (Subprogram_Elmt);
end loop;
end Validate_RACW_Primitives;
Error_Msg_N ("generic declaration not allowed in rci unit",
Parent (E));
- elsif (Ekind (E) = E_Function
- or else Ekind (E) = E_Procedure)
+ elsif (Ekind (E) = E_Function or else Ekind (E) = E_Procedure)
and then Has_Pragma_Inline (E)
then
Error_Msg_N
Id : Node_Id;
Param_Spec : Node_Id;
Param_Type : Entity_Id;
- Base_Param_Type : Entity_Id;
- Base_Under_Type : Entity_Id;
- Type_Decl : Node_Id;
Error_Node : Node_Id := N;
begin
end if;
if K = N_Subprogram_Declaration then
+ Id := Defining_Unit_Name (Specification (N));
Profile := Parameter_Specifications (Specification (N));
else pragma Assert (K = N_Object_Declaration);
Param_Spec := First (Profile);
while Present (Param_Spec) loop
Param_Type := Etype (Defining_Identifier (Param_Spec));
- Type_Decl := Parent (Param_Type);
if Ekind (Param_Type) = E_Anonymous_Access_Type then
if K = N_Subprogram_Declaration then
-- declaration and ignore full type declaration, unless this is
-- the only declaration for the type, e.g., as a limited record.
- elsif Is_Limited_Type (Param_Type)
- and then (Nkind (Type_Decl) = N_Private_Type_Declaration
- or else
- (Nkind (Type_Decl) = N_Full_Type_Declaration
- and then not (Has_Private_Declaration (Param_Type))
- and then Comes_From_Source (N)))
- then
- -- A limited parameter is legal only if user-specified Read and
- -- Write attributes exist for it. Second part of RM E.2.3 (14).
-
- if No (Full_View (Param_Type))
- and then Ekind (Param_Type) /= E_Record_Type
- then
- -- Type does not have completion yet, so if declared in
- -- the current RCI scope it is illegal, and will be flagged
- -- subsequently.
-
- return;
- end if;
-
- -- In Ada 95 the rules permit using a limited type that has
- -- user-specified Read and Write attributes that are specified
- -- in the private part of the package, whereas Ada 2005
- -- (AI-240) revises this to require the attributes to be
- -- "available" (implying that the attribute clauses must be
- -- visible to the RCI client). The Ada 95 rules violate the
- -- contract model for privacy, but we support both semantics
- -- for now for compatibility (note that ACATS test BXE2009
- -- checks a case that conforms to the Ada 95 rules but is
- -- illegal in Ada 2005). In the Ada 2005 case we check for the
- -- possibilities of visible TSS stream subprograms or explicit
- -- stream attribute definitions because the TSS subprograms
- -- can be hidden in the private part while the attribute
- -- definitions are still be available from the visible part.
-
- Base_Param_Type := Base_Type (Param_Type);
- Base_Under_Type := Base_Type (Underlying_Type
- (Base_Param_Type));
-
- if (Ada_Version < Ada_2005
- and then
- (No (TSS (Base_Param_Type, TSS_Stream_Read))
- or else
- No (TSS (Base_Param_Type, TSS_Stream_Write)))
- and then
- (No (TSS (Base_Under_Type, TSS_Stream_Read))
- or else
- No (TSS (Base_Under_Type, TSS_Stream_Write))))
- or else
- (Ada_Version >= Ada_2005
- and then
- (No (TSS (Base_Param_Type, TSS_Stream_Read))
- or else
- No (TSS (Base_Param_Type, TSS_Stream_Write))
- or else
- Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Read))
- or else
- Is_Hidden (TSS (Base_Param_Type, TSS_Stream_Write)))
- and then
- (not Has_Stream_Attribute_Definition
- (Base_Param_Type, TSS_Stream_Read)
- or else
- not Has_Stream_Attribute_Definition
- (Base_Param_Type, TSS_Stream_Write)))
- then
- if K = N_Subprogram_Declaration then
- Error_Node := Param_Spec;
- end if;
-
- if Ada_Version >= Ada_2005 then
- Error_Msg_N
- ("limited parameter in 'R'C'I unit "
- & "must have visible read/write attributes ",
- Error_Node);
- else
- Error_Msg_N
- ("limited parameter in 'R'C'I unit "
- & "must have read/write attributes ",
- Error_Node);
- end if;
- Explain_Limited_Type (Param_Type, Error_Node);
- end if;
-
- -- In Ada 95, any non-remote access type (or any type with a
- -- component of a non-remote access type) that is visible in an
- -- RCI unit comes from a Remote_Types or Remote_Call_Interface
- -- unit, and thus is already guaranteed to support external
- -- streaming. However in Ada 2005 we have to account for the case
- -- of named access types from declared pure units as well, which
- -- may or may not support external streaming, and so we need to
- -- perform a specific check for E.2.3(14/2) here.
-
- -- Note that if the declaration of the type itself is illegal, we
- -- do not perform this check since it might be a cascaded error.
-
- else
+ elsif No_External_Streaming (Param_Type) then
if K = N_Subprogram_Declaration then
Error_Node := Param_Spec;
end if;
- if Missing_Read_Write_Attributes (Param_Type)
- and then not Error_Posted (Param_Type)
- then
- Error_Msg_N
- ("parameter containing non-remote access in 'R'C'I "
- & "subprogram must have visible "
- & "Read and Write attributes", Error_Node);
+ Error_Msg_NE
+ ("formal of remote subprogram& "
+ & "must support external streaming",
+ Error_Node, Id);
+ if Is_Limited_Type (Param_Type) then
+ Explain_Limited_Type (Param_Type, Error_Node);
end if;
end if;
+
Next (Param_Spec);
end loop;
U_Typ : Entity_Id;
First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
+ function Stream_Attributes_Available (Typ : Entity_Id) return Boolean;
+ -- True if any stream attribute is available for Typ
+
+ ---------------------------------
+ -- Stream_Attributes_Available --
+ ---------------------------------
+
+ function Stream_Attributes_Available (Typ : Entity_Id) return Boolean
+ is
+ begin
+ return Stream_Attribute_Available (Typ, TSS_Stream_Read)
+ or else
+ Stream_Attribute_Available (Typ, TSS_Stream_Write)
+ or else
+ Stream_Attribute_Available (Typ, TSS_Stream_Input)
+ or else
+ Stream_Attribute_Available (Typ, TSS_Stream_Output);
+ end Stream_Attributes_Available;
+
+ -- Start of processing for Validate_RT_RAT_Component
+
begin
if not Is_Remote_Types (Name_U) then
return;
end if;
if Comes_From_Source (Typ) and then Is_Type (Typ) then
- if Missing_Read_Write_Attributes (Typ) then
+
+ -- Check that the type can be meaningfully transmitted to another
+ -- partition (E.2.2(8)).
+
+ if (Ada_Version < Ada_2005 and then Has_Non_Remote_Access (U_Typ))
+ or else
+ (Stream_Attributes_Available (Typ)
+ and then No_External_Streaming (U_Typ))
+ then
if Is_Non_Remote_Access_Type (Typ) then
Error_Msg_N ("error in non-remote access type", U_Typ);
else
projects / gcc.git / commitdiff