@@ -1899,7 +1899,7 @@ package body Exp_Ch6 is
Reset_Packed_Prefix;
- Temp := Make_Temporary (Loc, 'T', Actual);
+ Temp := Make_Temporary (Loc, 'T', Actual);
Incod := Relocate_Node (Actual);
Outcod := New_Copy_Tree (Incod);
@@ -1921,7 +1921,10 @@ package body Exp_Ch6 is
elsif Inside_Init_Proc then
- -- Could use a comment here to match comment below ???
+ -- Skip using the actual as the expression in Decl if we are in
+ -- an init proc and it is not a component which depends on a
+ -- discriminant, because, in this case, we need to use the actual
+ -- type of the component instead.
if Nkind (Actual) /= N_Selected_Component
or else
@@ -1930,8 +1933,9 @@ package body Exp_Ch6 is
then
Incod := Empty;
- -- Otherwise, keep the component in order to generate the proper
- -- actual subtype, that depends on enclosing discriminants.
+ -- Otherwise, keep the component so we can generate the proper
+ -- actual subtype - since the subtype depends on enclosing
+ -- discriminants.
else
null;
@@ -8600,6 +8600,8 @@ package body Exp_Dist is
Use_Opaque_Representation : Boolean;
+ Real_Rep : Node_Id;
+
begin
-- For a derived type, we can't go past the base type (to the
-- parent type) here, because that would cause the attribute's
@@ -8634,10 +8636,10 @@ package body Exp_Dist is
Use_Opaque_Representation := False;
if Has_Stream_Attribute_Definition
- (Typ, TSS_Stream_Output, At_Any_Place => True)
+ (Typ, TSS_Stream_Output, Real_Rep, At_Any_Place => True)
or else
Has_Stream_Attribute_Definition
- (Typ, TSS_Stream_Write, At_Any_Place => True)
+ (Typ, TSS_Stream_Write, Real_Rep, At_Any_Place => True)
then
-- If user-defined stream attributes are specified for this
-- type, use them and transmit data as an opaque sequence of
@@ -9438,6 +9440,8 @@ package body Exp_Dist is
-- When True, use stream attributes and represent type as an
-- opaque sequence of bytes.
+ Real_Rep : Node_Id;
+
begin
-- For a derived type, we can't go past the base type (to the
-- parent type) here, because that would cause the attribute's
@@ -9492,10 +9496,10 @@ package body Exp_Dist is
Use_Opaque_Representation := False;
if Has_Stream_Attribute_Definition
- (Typ, TSS_Stream_Output, At_Any_Place => True)
+ (Typ, TSS_Stream_Output, Real_Rep, At_Any_Place => True)
or else
Has_Stream_Attribute_Definition
- (Typ, TSS_Stream_Write, At_Any_Place => True)
+ (Typ, TSS_Stream_Write, Real_Rep, At_Any_Place => True)
then
-- If user-defined stream attributes are specified for this
-- type, use them and transmit data as an opaque sequence of
@@ -10624,6 +10628,8 @@ package body Exp_Dist is
Type_Name_Str : String_Id;
Type_Repo_Id_Str : String_Id;
+ Real_Rep : Node_Id;
+
-- Start of processing for Build_TypeCode_Function
begin
@@ -10657,10 +10663,10 @@ package body Exp_Dist is
(Type_Name_Str, Type_Repo_Id_Str, Parameters);
if Has_Stream_Attribute_Definition
- (Typ, TSS_Stream_Output, At_Any_Place => True)
+ (Typ, TSS_Stream_Output, Real_Rep, At_Any_Place => True)
or else
Has_Stream_Attribute_Definition
- (Typ, TSS_Stream_Write, At_Any_Place => True)
+ (Typ, TSS_Stream_Write, Real_Rep, At_Any_Place => True)
then
-- If user-defined stream attributes are specified for this
-- type, use them and transmit data as an opaque sequence of
@@ -2711,7 +2711,11 @@ package body Freeze is
-- List of freezing actions, left at No_List if none
Test_E : Entity_Id := E;
- -- This could use a comment ???
+ -- A local temporary used to test if freezing is necessary for E, since
+ -- its value can be set to something other than E in certain cases. For
+ -- example, E cannot be used directly in cases such as when it is an
+ -- Itype defined within a record - since it is the location of record
+ -- which matters.
procedure Add_To_Result (Fnod : Node_Id);
-- Add freeze action Fnod to list Result
@@ -29,16 +29,13 @@
-- --
------------------------------------------------------------------------------
-pragma Style_Checks (Off);
+pragma Style_Checks ("M512");
+-- Allow long lines in this unit
+pragma Warnings (Off, "non-static constant in preelaborated unit");
+-- We need package to be pure, and multiple constants in this unit will
+-- trigger the "non-static" warning - so ignore this since they are known at
+-- compile time and not a real problem for us.
package body System.UTF_32 is
@@ -1856,9 +1853,6 @@ package body System.UTF_32 is
(16#F0000#, 16#FFFFD#), -- (Co) <Plane 15 Private Use, First> .. <Plane 15 Private Use, Last>
(16#100000#, 16#10FFFD#)); -- (Co) <Plane 16 Private Use, First> .. <Plane 16 Private Use, Last>
- pragma Warnings (Off);
- -- Temporary, until pragma at start can be activated ???
-
-- The following array is parallel to the Unicode_Ranges table above. For
-- each entry in the Unicode_Ranges table, there is a corresponding entry
-- in the following table indicating the corresponding unicode category.
@@ -6506,9 +6500,6 @@ package body System.UTF_32 is
(16#1FBF0#, 16#1FBF9#), -- SEGMENTED DIGIT ZERO..SEGMENTED DIGIT NINE
(16#2F800#, 16#2FA1D#)); -- CJK COMPATIBILITY IDEOGRAPH-2F800..CJK COMPATIBILITY IDEOGRAPH-2FA1D
- pragma Warnings (On);
- -- Temporary until pragma Warnings at start can be activated ???
-
type Decomposition_Mapping is record
Item : UTF_32;
First_Char_Mapping : UTF_32;
@@ -12312,7 +12303,7 @@ package body System.UTF_32 is
return C = Nd;
end Is_UTF_32_Digit;
- ----------------------
+ ----------------------
-- Is_UTF_32_Letter --
----------------------
@@ -62,28 +62,24 @@ package body Ch2 is
-- Error recovery: can raise Error_Resync (cannot return Error)
- function P_Identifier (C : Id_Check := None) return Node_Id is
+ function P_Identifier
+ (C : Id_Check := None;
+ Force_Msg : Boolean := False)
+ return Node_Id
+ is
Ident_Node : Node_Id;
begin
-- All set if we do indeed have an identifier
- -- Code duplication, see Par_Ch3.P_Defining_Identifier???
-
if Token = Tok_Identifier then
Check_Future_Keyword;
- Ident_Node := Token_Node;
- Scan; -- past Identifier
- return Ident_Node;
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
elsif Is_Reserved_Identifier (C) then
- Scan_Reserved_Identifier (Force_Msg => False);
- Ident_Node := Token_Node;
- Scan; -- past the node
- return Ident_Node;
+ Scan_Reserved_Identifier (Force_Msg => Force_Msg);
-- Otherwise we have junk that cannot be interpreted as an identifier
@@ -91,6 +87,15 @@ package body Ch2 is
T_Identifier; -- to give message
raise Error_Resync;
end if;
+
+ if Style_Check then
+ Style.Check_Defining_Identifier_Casing;
+ end if;
+
+ Ident_Node := Token_Node;
+ Scan; -- past the identifier
+
+ return Ident_Node;
end P_Identifier;
--------------------------
@@ -209,39 +209,9 @@ package body Ch3 is
-- Error recovery: can raise Error_Resync
function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
- Ident_Node : Node_Id;
+ Ident_Node : Node_Id := P_Identifier (C, True);
begin
- -- Scan out the identifier. Note that this code is essentially identical
- -- to P_Identifier, except that in the call to Scan_Reserved_Identifier
- -- we set Force_Msg to True, since we want at least one message for each
- -- separate declaration (but not use) of a reserved identifier.
-
- -- Duplication should be removed, common code should be factored???
-
- if Token = Tok_Identifier then
- Check_Future_Keyword;
-
- -- If we have a reserved identifier, manufacture an identifier with
- -- a corresponding name after posting an appropriate error message
-
- elsif Is_Reserved_Identifier (C) then
- Scan_Reserved_Identifier (Force_Msg => True);
-
- -- Otherwise we have junk that cannot be interpreted as an identifier
-
- else
- T_Identifier; -- to give message
- raise Error_Resync;
- end if;
-
- if Style_Check then
- Style.Check_Defining_Identifier_Casing;
- end if;
-
- Ident_Node := Token_Node;
- Scan; -- past the identifier
-
-- If we already have a defining identifier, clean it out and make
-- a new clean identifier. This situation arises in some error cases
-- and we need to fix it.
@@ -649,10 +649,16 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- procedure more than once for the same pragma. All parse-time pragma
-- handling must be prepared to handle such multiple calls correctly.
- function P_Identifier (C : Id_Check := None) return Node_Id;
+ function P_Identifier
+ (C : Id_Check := None;
+ Force_Msg : Boolean := False) return Node_Id;
-- Scans out an identifier. The parameter C determines the treatment
-- of reserved identifiers. See declaration of Id_Check for details.
+ -- An appropriate error message, pointing to the token, is also issued
+ -- if either this is the first occurrence of misuse of this identifier,
+ -- or if Force_Msg is True.
+
function P_Pragmas_Opt return List_Id;
-- This function scans for a sequence of pragmas in other than a
-- declaration sequence or statement sequence context. All pragmas
@@ -12555,20 +12555,29 @@ package body Sem_Attr is
is
Etyp : Entity_Id := Typ;
+ Real_Rep : Node_Id;
+
-- Start of processing for Stream_Attribute_Available
begin
- -- We need some comments in this body ???
+ -- Test if the attribute is specified directly on the type
- if Has_Stream_Attribute_Definition (Typ, Nam) then
+ if Has_Stream_Attribute_Definition (Typ, Nam, Real_Rep) then
return True;
end if;
+ -- We assume class-wide types have stream attributes
+ -- when they are not limited. Otherwise we recurse on the
+ -- parent type.
+
if Is_Class_Wide_Type (Typ) then
return not Is_Limited_Type (Typ)
or else Stream_Attribute_Available (Etype (Typ), Nam);
end if;
+ -- Non-class-wide abstract types cannot have Input streams
+ -- specified.
+
if Nam = TSS_Stream_Input
and then Is_Abstract_Type (Typ)
and then not Is_Class_Wide_Type (Typ)
@@ -12576,6 +12585,8 @@ package body Sem_Attr is
return False;
end if;
+ -- Otherwise, nonlimited types have stream attributes
+
if not (Is_Limited_Type (Typ)
or else (Present (Partial_View)
and then Is_Limited_Type (Partial_View)))
@@ -12587,13 +12598,13 @@ package body Sem_Attr is
if Nam = TSS_Stream_Input
and then Ada_Version >= Ada_2005
- and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
+ and then Stream_Attribute_Available (Etyp, TSS_Stream_Read, Real_Rep)
then
return True;
elsif Nam = TSS_Stream_Output
and then Ada_Version >= Ada_2005
- and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
+ and then Stream_Attribute_Available (Etyp, TSS_Stream_Write, Real_Rep)
then
return True;
end if;
@@ -12607,7 +12618,7 @@ package body Sem_Attr is
begin
Etyp := Etype (Etyp);
- if Has_Stream_Attribute_Definition (Etyp, Nam) then
+ if Has_Stream_Attribute_Definition (Etyp, Nam, Real_Rep) then
if not Derivation_Too_Early_To_Inherit (Derived_Type, Nam) then
return True;
end if;
@@ -432,12 +432,13 @@ package body Sem_Cat is
-------------------------------
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
+ Real_Rep : Node_Id;
begin
return True
and then Has_Stream_Attribute_Definition
- (E, TSS_Stream_Read, At_Any_Place => True)
+ (E, TSS_Stream_Read, Real_Rep, At_Any_Place => True)
and then Has_Stream_Attribute_Definition
- (E, TSS_Stream_Write, At_Any_Place => True);
+ (E, TSS_Stream_Write, Real_Rep, At_Any_Place => True);
end Has_Read_Write_Attributes;
-------------------------------------
@@ -447,18 +448,11 @@ package body Sem_Cat is
function Has_Stream_Attribute_Definition
(Typ : Entity_Id;
Nam : TSS_Name_Type;
+ Real_Rep : out Node_Id;
At_Any_Place : Boolean := False) return Boolean
is
Rep_Item : Node_Id;
- Real_Rep : Node_Id;
- -- The stream operation may be specified by an attribute definition
- -- clause in the source, or by an aspect that generates such an
- -- attribute definition. For an aspect, the generated attribute
- -- definition may be placed at the freeze point of the full view of
- -- the type, but the aspect specification makes the operation visible
- -- to a client wherever the partial view is visible.
-
begin
-- We start from the declaration node and then loop until the end of
-- the list until we find the requested attribute definition clause.
@@ -467,6 +461,8 @@ package body Sem_Cat is
-- inserted by the expander at the point where the clause occurs),
-- unless At_Any_Place is true.
+ Real_Rep := Empty;
+
Rep_Item := First_Rep_Item (Typ);
while Present (Rep_Item) loop
Real_Rep := Rep_Item;
@@ -511,7 +507,7 @@ package body Sem_Cat is
and then Present (Full_View (Typ))
then
return Has_Stream_Attribute_Definition
- (Underlying_Type (Typ), Nam, At_Any_Place);
+ (Underlying_Type (Typ), Nam, Real_Rep, At_Any_Place);
-- Otherwise, if At_Any_Place is true, return True if the attribute is
-- available at any place; if it is false, return True only if the
@@ -43,6 +43,7 @@ package Sem_Cat is
function Has_Stream_Attribute_Definition
(Typ : Entity_Id;
Nam : TSS_Name_Type;
+ Real_Rep : out Node_Id;
At_Any_Place : Boolean := False) return Boolean;
-- True when there is a attribute definition clause specifying attribute
-- Nam for Typ. In Ada 2005 mode, returns True only when the attribute
@@ -54,6 +55,14 @@ package Sem_Cat is
-- specific type, excluding inherited definitions, the flags
-- Has_Specified_Stream_* can be used instead).
+ -- The stream operation may be specified by an attribute definition
+ -- clause in the source, or by an aspect that generates such an
+ -- attribute definition. For an aspect, the generated attribute
+ -- definition may be placed at the freeze point of the full view of
+ -- the type, but the aspect specification makes the operation visible
+ -- to a client wherever the partial view is visible. This real
+ -- representation is returned in the Real_Rep parameter.
+
function In_Preelaborated_Unit return Boolean;
-- Determines if the current scope is within a preelaborated compilation
-- unit, that is one to which one of the pragmas Preelaborate, Pure,
@@ -235,7 +235,9 @@ package body Sem_Type is
if Ada_Version >= Ada_2005 then
if Nkind (N) in N_Binary_Op then
Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);
- elsif Nkind (N) = N_Function_Call then
+ elsif Nkind (N) = N_Function_Call
+ and then Ekind (Name) = E_Function
+ then
Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);
end if;
end if;
@@ -2357,19 +2359,24 @@ package body Sem_Type is
Form_Parm : Node_Id;
begin
- -- Why is check on E needed below ???
- -- In any case this para needs comments ???
+ if Is_Overloaded (N) then
+ -- Move through the formals and actuals of the call to
+ -- determine if an abstract interpretation exists.
- if Is_Overloaded (N) and then Is_Overloadable (E) then
Act_Parm := First_Actual (N);
Form_Parm := First_Formal (E);
while Present (Act_Parm) and then Present (Form_Parm) loop
Act := Act_Parm;
+ -- Extract the actual from a parameter association
+
if Nkind (Act) = N_Parameter_Association then
Act := Explicit_Actual_Parameter (Act);
end if;
+ -- Use the actual and the type of its correponding formal to test
+ -- for an abstract interpretation and return it when found.
+
Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
if Present (Abstr_Op) then
@@ -2381,6 +2388,8 @@ package body Sem_Type is
end loop;
end if;
+ -- Otherwise, return empty
+
return Empty;
end Function_Interp_Has_Abstract_Op;
@@ -7705,62 +7705,30 @@ package body Sem_Util is
function Derivation_Too_Early_To_Inherit
(Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is
+
Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
Parent_Type : Entity_Id;
+
+ Real_Rep : Node_Id;
+
+ -- Start of processing for Derivation_Too_Early_To_Inherit
+
begin
if Is_Derived_Type (Btyp) then
Parent_Type := Implementation_Base_Type (Etype (Btyp));
pragma Assert (Parent_Type /= Btyp);
+
if Has_Stream_Attribute_Definition
- (Parent_Type, Streaming_Op)
+ (Parent_Type, Streaming_Op, Real_Rep => Real_Rep)
+
and then In_Same_Extended_Unit (Btyp, Parent_Type)
and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) =
Instantiation (Get_Source_File_Index (Sloc (Parent_Type)))
then
- declare
- -- ??? Avoid code duplication here with
- -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a
- -- new function to be called from both places?
-
- Rep_Item : Node_Id := First_Rep_Item (Parent_Type);
- Real_Rep : Node_Id;
- Found : Boolean := False;
- begin
- while Present (Rep_Item) loop
- Real_Rep := Rep_Item;
-
- if Nkind (Rep_Item) = N_Aspect_Specification then
- Real_Rep := Aspect_Rep_Item (Rep_Item);
- end if;
-
- if Nkind (Real_Rep) = N_Attribute_Definition_Clause then
- case Chars (Real_Rep) is
- when Name_Read =>
- Found := Streaming_Op = TSS_Stream_Read;
-
- when Name_Write =>
- Found := Streaming_Op = TSS_Stream_Write;
-
- when Name_Input =>
- Found := Streaming_Op = TSS_Stream_Input;
-
- when Name_Output =>
- Found := Streaming_Op = TSS_Stream_Output;
-
- when others =>
- null;
- end case;
- end if;
-
- if Found then
- return Earlier_In_Extended_Unit (Btyp, Real_Rep);
- end if;
-
- Next_Rep_Item (Rep_Item);
- end loop;
- end;
+ return Earlier_In_Extended_Unit (Btyp, Real_Rep);
end if;
end if;
+
return False;
end Derivation_Too_Early_To_Inherit;