+2015-05-26 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.ads, sem_util.adb, sem_ch4.adb: Minor reformatting.
+
+2015-05-26 Robert Dewar <dewar@adacore.com>
+
+ * exp_unst.adb, exp_unst.ads: Change to using Subps table index for
+ making AREC entity names unique.
+
+2015-05-26 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_cat.adb (Has_Stream_Attribute_Definition): If the type
+ has aspect specifications, examine the corresponding list of
+ representation items to determine whether there is a visible
+ stream operation. The attribute definition clause generated from
+ the aspect will be inserted at the freeze point of the type,
+ which may be in the private part and not directly visible,
+ but the aspect makes the operation available to a client.
+
2015-05-26 Robert Dewar <dewar@adacore.com>
* sem_util.adb: Minor code reorganization.
-- Object_Size clauses for a given entity.
-- Has_Out_Or_In_Out_Parameter (Flag110)
--- Present in subprograms, generic subprograms, entries and entry
+-- Present in subprograms, generic subprograms, entries, and entry
-- families. Set if they have at least one OUT or IN OUT parameter
-- (allowed for functions only in Ada 2012).
-----------------------
procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
- function AREC_String (Lev : Pos) return String;
- -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
+ function AREC_Name (J : Pos; S : String) return Name_Id;
+ -- Returns name for string ARECjS, where j is the decimal value of j
function Enclosing_Subp (Subp : SI_Type) return SI_Type;
-- Subp is the index of a subprogram which has a Lev greater than 1.
-- function returns the level of nesting (Subp = 1, subprograms that
-- are immediately nested within Subp = 2, etc).
+ function Img_Pos (N : Pos) return String;
+ -- Return image of N without leading blank
+
function Subp_Index (Sub : Entity_Id) return SI_Type;
-- Given the entity for a subprogram, return corresponding Subps index
- function Suffixed_Name (Ent : Entity_Id) return Name_Id;
- -- Given an entity Ent, return its name (Char (Ent)) suffixed with
- -- two underscores and the entity number, to ensure a unique name.
-
- function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id;
+ function Upref_Name
+ (Ent : Entity_Id;
+ Index : Pos;
+ Clist : List_Id) return Name_Id;
-- This function returns the name to be used in the activation record to
-- reference the variable uplevel. Clist is the list of components that
- -- have been created in the activation record so far. Normally this is
- -- just a copy of the Chars field of the entity. The exception is when
- -- the name has already been used, in which case we suffix the name with
- -- the entity number to avoid duplication. This happens with declare
- -- blocks and generic parameters at least.
+ -- have been created in the activation record so far. Normally the name
+ -- is just a copy of the Chars field of the entity. The exception is
+ -- when the name has already been used, in which case we suffix the name
+ -- with the index value Index to avoid duplication. This happens with
+ -- declare blocks and generic parameters at least.
- -----------------
- -- AREC_String --
- -----------------
+ ---------------
+ -- AREC_Name --
+ ---------------
- function AREC_String (Lev : Pos) return String is
+ function AREC_Name (J : Pos; S : String) return Name_Id is
begin
- if Lev > 9 then
- return AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48);
- else
- return "AREC" & Character'Val (Lev + 48);
- end if;
- end AREC_String;
+ return Name_Find_Str ("AREC" & Img_Pos (J) & S);
+ end AREC_Name;
--------------------
-- Enclosing_Subp --
end loop;
end Get_Level;
+ -------------
+ -- Img_Pos --
+ -------------
+
+ function Img_Pos (N : Pos) return String is
+ Buf : String (1 .. 20);
+ Ptr : Natural;
+ NV : Nat;
+
+ begin
+ Ptr := Buf'Last;
+ NV := N;
+ while NV /= 0 loop
+ Buf (Ptr) := Character'Val (48 + NV mod 10);
+ Ptr := Ptr - 1;
+ NV := NV / 10;
+ end loop;
+
+ return Buf (Ptr + 1 .. Buf'Last);
+ end Img_Pos;
+
----------------
-- Subp_Index --
----------------
return SI_Type (UI_To_Int (Subps_Index (Sub)));
end Subp_Index;
- -------------------
- -- Suffixed_Name --
- -------------------
-
- function Suffixed_Name (Ent : Entity_Id) return Name_Id is
- begin
- Get_Name_String (Chars (Ent));
- Add_Str_To_Name_Buffer ("__");
- Add_Nat_To_Name_Buffer (Nat (Ent));
- return Name_Enter;
- end Suffixed_Name;
-
----------------
-- Upref_Name --
----------------
- function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id is
+ function Upref_Name
+ (Ent : Entity_Id;
+ Index : Pos;
+ Clist : List_Id) return Name_Id
+ is
C : Node_Id;
begin
C := First (Clist);
if No (C) then
return Chars (Ent);
elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
- return Suffixed_Name (Ent);
+ return Name_Find_Str
+ (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
else
Next (C);
end if;
declare
STJ : Subp_Entry renames Subps.Table (J);
Loc : constant Source_Ptr := Sloc (STJ.Bod);
- ARS : constant String := AREC_String (STJ.Lev);
begin
-- First we create the ARECnF entity for the additional formal for
if STJ.Uplevel_Ref < STJ.Lev then
STJ.ARECnF :=
- Make_Defining_Identifier (Loc,
- Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F"));
+ Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
end if;
-- Define the AREC entities for the activation record if needed
if STJ.Declares_AREC then
STJ.ARECn :=
- Make_Defining_Identifier (Loc, Name_Find_Str (ARS));
+ Make_Defining_Identifier (Loc, AREC_Name (J, ""));
STJ.ARECnT :=
- Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "T"));
+ Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
STJ.ARECnPT :=
- Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "PT"));
+ Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
STJ.ARECnP :=
- Make_Defining_Identifier (Loc, Name_Find_Str (ARS & "P"));
+ Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
-- Define uplink component entity if inner nesting case
if Present (STJ.ARECnF) then
- declare
- ARS1 : constant String := AREC_String (STJ.Lev - 1);
- begin
- STJ.ARECnU :=
- Make_Defining_Identifier (Loc,
- Chars => Name_Find_Str (ARS1 & "U"));
- end;
+ STJ.ARECnU :=
+ Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
end if;
end if;
end;
-- List of new declarations we create
begin
- -- Suffix the ARECnT and ARECnPT names to make sure that
- -- they are unique when Cprint moves the declarations to
- -- the outer level.
-
- Set_Chars (STJ.ARECnT, Suffixed_Name (STJ.ARECnT));
- Set_Chars (STJ.ARECnPT, Suffixed_Name (STJ.ARECnPT));
-
-- Build list of component declarations for ARECnT
Clist := Empty_List;
-- If we are in a subprogram that has a static link that
-- is passed in (as indicated by ARECnF being defined),
- -- then include ARECnU : ARECmPT where m is one less than
- -- the current level and the entity ARECnPT comes from
- -- the enclosing subprogram.
+ -- then include ARECnU : ARECmPT where ARECmPT comes from
+ -- the level one higher than the current level, and the
+ -- entity ARECnPT comes from the enclosing subprogram.
if Present (STJ.ARECnF) then
declare
Elmt : Elmt_Id;
Uent : Entity_Id;
+ Indx : Nat;
+ -- 1's origin of index in list of elements. This is
+ -- used to uniquify names if needed in Upref_Name.
+
begin
Elmt := First_Elmt (STJ.Uents);
+ Indx := 0;
while Present (Elmt) loop
Uent := Node (Elmt);
+ Indx := Indx + 1;
Comp :=
Make_Defining_Identifier (Loc,
- Chars => Upref_Name (Uent, Clist));
+ Chars => Upref_Name (Uent, Indx, Clist));
Set_Activation_Record_Component
(Uent, Comp);
-- The fields of AREC1 are set at the point the corresponding entity
-- is declared (immediately for parameters).
- -- Note: the 1 in all these names represents the fact that we are at the
- -- outer level of nesting. As we will see later, deeper levels of nesting
- -- will use AREC2, AREC3, ...
+ -- Note: the 1 in all these names is a unique index number. Different
+ -- scopes requiring different ARECnT declarations will have different
+ -- values of n to ensure uniqueness.
-- Note: normally the field names in the activation record match the
-- name of the entity. An exception is when the entity is declared in
-- What we do is to always generate a local constant for any dynamic
-- bound in a dynamic subtype xx with name xx_FIRST or xx_LAST. The one
- -- case where we can skip this is where the bound is For
- -- example in the third example above, subtype dynam is expanded as
+ -- case where we can skip this is where the bound is e.g. in the third
+ -- example above, subtype dynam is expanded as
-- dynam_LAST : constant Integer := y + 3;
-- subtype dynam is integer range x .. dynam_LAST;
-- return inner1 (x, AREC1P);
-- end case4x;
- -- As can be seen in this example, the level number following AREC in the
- -- names avoids any confusion between AREC names at different levels.
+ -- As can be seen in this example, the index numbers following AREC in the
+ -- generated names avoid confusion between AREC names at different levels.
-------------------------
-- Name Disambiguation --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
At_Any_Place : Boolean := False) return Boolean
is
Rep_Item : Node_Id;
- Full_Type : Entity_Id := Typ;
+ 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
- -- In the case of a type derived from a private view, any specified
- -- stream attributes will be attached to the derived type's underlying
- -- type rather the derived type entity itself (which is itself private).
-
- if Is_Private_Type (Typ)
- and then Is_Derived_Type (Typ)
- and then Present (Full_View (Typ))
- then
- Full_Type := Underlying_Type (Typ);
- end if;
-
-- We start from the declaration node and then loop until the end of
-- the list until we find the requested attribute definition clause.
-- In Ada 2005 mode, clauses are ignored if they are not currently
-- inserted by the expander at the point where the clause occurs),
-- unless At_Any_Place is true.
- Rep_Item := First_Rep_Item (Full_Type);
+ Rep_Item := First_Rep_Item (Typ);
while Present (Rep_Item) loop
- if Nkind (Rep_Item) = N_Attribute_Definition_Clause then
- case Chars (Rep_Item) is
+ Real_Rep := Rep_Item;
+
+ -- If the representation item is an aspect specification, retrieve
+ -- the corresponding pragma or attribute definition.
+
+ 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 =>
exit when Nam = TSS_Stream_Read;
Next_Rep_Item (Rep_Item);
end loop;
- -- 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 attribute is
- -- currently visible.
+ -- If not found, and the type is derived from a private view, check
+ -- for a stream attribute inherited from parent. Any specified stream
+ -- attributes will be attached to the derived type's underlying type
+ -- rather the derived type entity itself (which is itself private).
+
+ if No (Rep_Item)
+ and then Is_Private_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ and then Present (Full_View (Typ))
+ then
+ return Has_Stream_Attribute_Definition
+ (Underlying_Type (Typ), Nam, 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
+ -- attribute is currently visible.
- return Present (Rep_Item)
- and then (Ada_Version < Ada_2005
- or else At_Any_Place
- or else not Is_Hidden (Entity (Rep_Item)));
+ else
+ return Present (Rep_Item)
+ and then (Ada_Version < Ada_2005
+ or else At_Any_Place
+ or else not Is_Hidden (Entity (Rep_Item)));
+ end if;
end Has_Stream_Attribute_Definition;
----------------------------
----------------------------
-- The identification of conflicts in calls to functions with writable
- -- actuals is performed in the analysis phase of the frontend to ensure
+ -- actuals is performed in the analysis phase of the front end to ensure
-- that it reports exactly the same errors compiling with and without
-- expansion enabled. It is performed in two stages:
- -- 1) When a call to a function with out-mode parameters is found
- -- we climb to the outermost enclosing construct which can be
+ -- 1) When a call to a function with out-mode parameters is found,
+ -- we climb to the outermost enclosing construct that can be
-- evaluated in arbitrary order and we mark it with the flag
-- Check_Actuals.
- -- 2) When the analysis of the marked node is complete then we
- -- traverse its decorated subtree searching for conflicts
- -- (see function Sem_Util.Check_Function_Writable_Actuals).
+ -- 2) When the analysis of the marked node is complete, we traverse
+ -- its decorated subtree searching for conflicts (see function
+ -- Sem_Util.Check_Function_Writable_Actuals).
- -- The unique exception to this general rule are aggregates, since
- -- their analysis is performed by the frontend in the resolution
- -- phase. For aggregates we do not climb to its enclosing construct:
+ -- The unique exception to this general rule is for aggregates, since
+ -- their analysis is performed by the front end in the resolution
+ -- phase. For aggregates we do not climb to their enclosing construct:
-- we restrict the analysis to the subexpressions initializing the
-- aggregate components.
-- This implies that the analysis of expressions containing aggregates
- -- is not complete since there may be conflicts on writable actuals
+ -- is not complete, since there may be conflicts on writable actuals
-- involving subexpressions of the enclosing logical or arithmetic
-- expressions. However, we cannot wait and perform the analysis when
- -- the whole subtree is resolved since the subtrees may be transformed
+ -- the whole subtree is resolved, since the subtrees may be transformed,
-- thus adding extra complexity and computation cost to identify and
-- report exactly the same errors compiling with and without expansion
-- enabled.
function Is_Arbitrary_Evaluation_Order_Construct
(N : Node_Id) return Boolean;
- -- Return True if N is an Ada construct which may evaluate in
- -- arbitrary order. This function does not cover all the language
- -- constructs which can be evaluated in arbitrary order but the
+ -- Return True if N is an Ada construct which may be evaluated in
+ -- an arbitrary order. This function does not cover all the language
+ -- constructs that can be evaluated in arbitrary order, but only the
-- subset needed for AI05-0144.
---------------------------------------------
begin
while Present (P) loop
- -- For object declarations we can climb to such node from
+ -- For object declarations we can climb to the node from
-- its object definition branch or from its initializing
-- expression. We prefer to mark the child node as the
-- outermost construct to avoid adding further complexity
- -- to the routine which will take care later of
+ -- to the routine that will later take care of
-- performing the writable actuals check.
if Is_Arbitrary_Evaluation_Order_Construct (P)
Check_Writable_Actuals (N);
- -- If found and the outermost construct which can be evaluated in
- -- arbitrary order is precisely this call then check all its
+ -- If found and the outermost construct that can be evaluated in
+ -- an arbitrary order is precisely this call, then check all its
-- actuals.
if Check_Actuals (N) then
then
return Skip;
- -- For now we skip aggregate discriminants since they require
+ -- For now we skip aggregate discriminants, since they require
-- performing the analysis in two phases to identify conflicts:
-- first one analyzing discriminants and second one analyzing
- -- the rest of components (since at runtime discriminants are
+ -- the rest of components (since at run time, discriminants are
-- evaluated prior to components): too much computation cost
-- to identify a corner case???
-- Report the error on the second occurrence of the
-- identifier. We cannot assume that N is the second
- -- occurrence since traverse_func walks through Field2
- -- last (see comment in the body of traverse_func).
+ -- occurrence, since Traverse_Func walks through Field2
+ -- last (see comment in the body of Traverse_Func).
declare
Elmt : Elmt_Id;
projects / gcc.git / commitdiff