+2014-07-17 Vincent Celier <celier@adacore.com>
+
+ * gnatbind.adb: Change in message "try ... for more information".
+
+2014-07-17 Robert Dewar <dewar@adacore.com>
+
+ * sprint.adb: Code clean up.
+
+2014-07-17 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Find_Last_Init): Relocate local variables to
+ the relevant code section. Add new local constant Obj_Id. When
+ a limited controlled object is initialized by a function call,
+ the build-in-place object access function call acts as the last
+ initialization statement.
+ * exp_util.adb (Is_Object_Access_BIP_Func_Call): New routine.
+ (Is_Secondary_Stack_BIP_Func_Call): Code reformatting.
+ * exp_util.ads (Is_Object_Access_BIP_Func_Call): New routine.
+
+2014-07-17 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Analyze_Generic_Renaming): For generic subprograms,
+ propagate intrinsic flag to renamed entity, to allow e.g. renaming
+ of Unchecked_Conversion.
+ * sem_ch3.adb (Analyze_Declarations): Do not analyze contracts
+ if the declaration has errors.
+
+2014-07-17 Ed Schonberg <schonberg@adacore.com>
+
+ * a-rbtgbk.adb: a-rbtgbk.adb (Generic_Insert_Post): Check whether
+ container is busy before checking whether capacity allows for
+ a further insertion. Insertion in a busy container that is full
+ raises Program_Error rather than Capacity_Error. Previous to that
+ patch which exception was raised varied among container types.
+
2014-07-17 Robert Dewar <dewar@adacore.com>
* g-comlin.ads, g-comlin.adb: Minor clean up.
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2014, 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- --
N : Nodes_Type renames Tree.Nodes;
begin
- if Tree.Length >= Tree.Capacity then
- raise Capacity_Error with "not enough capacity to insert new item";
- end if;
-
if Tree.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
+ if Tree.Length >= Tree.Capacity then
+ raise Capacity_Error with "not enough capacity to insert new item";
+ end if;
+
Z := New_Node;
pragma Assert (Z /= 0);
Last_Init : out Node_Id;
Body_Insert : out Node_Id)
is
- Nod_1 : Node_Id := Empty;
- Nod_2 : Node_Id := Empty;
- Utyp : Entity_Id;
-
function Is_Init_Call
(N : Node_Id;
Typ : Entity_Id) return Boolean;
return Result;
end Next_Suitable_Statement;
+ -- Local variables
+
+ Obj_Id : constant Entity_Id := Defining_Entity (Decl);
+ Nod_1 : Node_Id := Empty;
+ Nod_2 : Node_Id := Empty;
+ Stmt : Node_Id;
+ Utyp : Entity_Id;
+
-- Start of processing for Find_Last_Init
begin
Utyp := Full_View (Utyp);
end if;
+ -- A limited controlled object initialized by a function call uses
+ -- the build-in-place machinery to obtain its value.
+
+ -- Obj : Lim_Controlled_Type := Func_Call;
+
+ -- is expanded into
+
+ -- Obj : Lim_Controlled_Type;
+ -- type Ptr_Typ is access Lim_Controlled_Type;
+ -- Temp : constant Ptr_Typ :=
+ -- Func_Call
+ -- (BIPalloc => 1,
+ -- BIPaccess => Obj'Unrestricted_Access)'reference;
+
+ -- In this scenario the declaration of the temporary acts as the
+ -- last initialization statement.
+
+ if Is_Limited_Type (Utyp)
+ and then Has_Init_Expression (Decl)
+ and then No (Expression (Decl))
+ then
+ Stmt := Next (Decl);
+ while Present (Stmt) loop
+ if Nkind (Stmt) = N_Object_Declaration
+ and then Present (Expression (Stmt))
+ and then Is_Object_Access_BIP_Func_Call
+ (Expr => Expression (Stmt),
+ Obj_Id => Obj_Id)
+ then
+ Last_Init := Stmt;
+ exit;
+ end if;
+
+ Next (Stmt);
+ end loop;
+
-- The init procedures are arranged as follows:
-- Object : Controlled_Type;
-- where the user-defined initialize may be optional or may appear
-- inside a block when abort deferral is needed.
- Nod_1 := Next_Suitable_Statement (Decl);
- if Present (Nod_1) then
- Nod_2 := Next_Suitable_Statement (Nod_1);
+ else
+ Nod_1 := Next_Suitable_Statement (Decl);
- -- The statement following an object declaration is always a
- -- call to the type init proc.
+ if Present (Nod_1) then
+ Nod_2 := Next_Suitable_Statement (Nod_1);
- Last_Init := Nod_1;
- end if;
+ -- The statement following an object declaration is always a
+ -- call to the type init proc.
- -- Optional user-defined init or deep init processing
+ Last_Init := Nod_1;
+ end if;
- if Present (Nod_2) then
+ -- Optional user-defined init or deep init processing
- -- The statement following the type init proc may be a block
- -- statement in cases where abort deferral is required.
+ if Present (Nod_2) then
- if Nkind (Nod_2) = N_Block_Statement then
- declare
- HSS : constant Node_Id :=
- Handled_Statement_Sequence (Nod_2);
- Stmt : Node_Id;
+ -- The statement following the type init proc may be a block
+ -- statement in cases where abort deferral is required.
- begin
- if Present (HSS)
- and then Present (Statements (HSS))
- then
- Stmt := First (Statements (HSS));
+ if Nkind (Nod_2) = N_Block_Statement then
+ declare
+ HSS : constant Node_Id :=
+ Handled_Statement_Sequence (Nod_2);
+ Stmt : Node_Id;
- -- Examine individual block statements and locate the
- -- call to [Deep_]Initialze.
+ begin
+ if Present (HSS)
+ and then Present (Statements (HSS))
+ then
+ -- Examine individual block statements and locate
+ -- the call to [Deep_]Initialze.
- while Present (Stmt) loop
- if Is_Init_Call (Stmt, Utyp) then
- Last_Init := Stmt;
- Body_Insert := Nod_2;
+ Stmt := First (Statements (HSS));
+ while Present (Stmt) loop
+ if Is_Init_Call (Stmt, Utyp) then
+ Last_Init := Stmt;
+ Body_Insert := Nod_2;
- exit;
- end if;
+ exit;
+ end if;
- Next (Stmt);
- end loop;
- end if;
- end;
+ Next (Stmt);
+ end loop;
+ end if;
+ end;
- elsif Is_Init_Call (Nod_2, Utyp) then
- Last_Init := Nod_2;
+ elsif Is_Init_Call (Nod_2, Utyp) then
+ Last_Init := Nod_2;
+ end if;
end if;
end if;
end Find_Last_Init;
-- Set a new value for the state counter and insert the statement
-- after the object declaration. Generate:
- --
+
-- Counter := <value>;
Inc_Decl :=
Label_Construct => Label));
-- Create the associated jump with this object, generate:
- --
+
-- when <counter> =>
-- goto L<counter>;
and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
end Is_Non_BIP_Func_Call;
+ ------------------------------------
+ -- Is_Object_Access_BIP_Func_Call --
+ ------------------------------------
+
+ function Is_Object_Access_BIP_Func_Call
+ (Expr : Node_Id;
+ Obj_Id : Entity_Id) return Boolean
+ is
+ Access_Nam : Name_Id := No_Name;
+ Actual : Node_Id;
+ Call : Node_Id;
+ Formal : Node_Id;
+ Param : Node_Id;
+
+ begin
+ -- Build-in-place calls usually appear in 'reference format. Note that
+ -- the accessibility check machinery may add an extra 'reference due to
+ -- side effect removal.
+
+ Call := Expr;
+ while Nkind (Call) = N_Reference loop
+ Call := Prefix (Call);
+ end loop;
+
+ if Nkind_In (Call, N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
+ then
+ Call := Expression (Call);
+ end if;
+
+ if Is_Build_In_Place_Function_Call (Call) then
+
+ -- Examine all parameter associations of the function call
+
+ Param := First (Parameter_Associations (Call));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association
+ and then Nkind (Selector_Name (Param)) = N_Identifier
+ then
+ Formal := Selector_Name (Param);
+ Actual := Explicit_Actual_Parameter (Param);
+
+ -- Construct the name of formal BIPaccess. It is much easier to
+ -- extract the name of the function using an arbitrary formal's
+ -- scope rather than the Name field of Call.
+
+ if Access_Nam = No_Name and then Present (Entity (Formal)) then
+ Access_Nam :=
+ New_External_Name
+ (Chars (Scope (Entity (Formal))),
+ BIP_Formal_Suffix (BIP_Object_Access));
+ end if;
+
+ -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been
+ -- found.
+
+ if Chars (Formal) = Access_Nam
+ and then Nkind (Actual) = N_Attribute_Reference
+ and then Attribute_Name (Actual) = Name_Unrestricted_Access
+ and then Nkind (Prefix (Actual)) = N_Identifier
+ and then Entity (Prefix (Actual)) = Obj_Id
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Param);
+ end loop;
+ end if;
+
+ return False;
+ end Is_Object_Access_BIP_Func_Call;
+
----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------
--------------------------------------
function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
- Call : Node_Id := Expr;
+ Alloc_Nam : Name_Id := No_Name;
+ Actual : Node_Id;
+ Call : Node_Id := Expr;
+ Formal : Node_Id;
+ Param : Node_Id;
begin
-- Build-in-place calls usually appear in 'reference format. Note that
end if;
if Is_Build_In_Place_Function_Call (Call) then
- declare
- Access_Nam : Name_Id := No_Name;
- Actual : Node_Id;
- Param : Node_Id;
- Formal : Node_Id;
-
- begin
- -- Examine all parameter associations of the function call
-
- Param := First (Parameter_Associations (Call));
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association
- and then Nkind (Selector_Name (Param)) = N_Identifier
- then
- Formal := Selector_Name (Param);
- Actual := Explicit_Actual_Parameter (Param);
- -- Construct the name of formal BIPalloc. It is much easier
- -- to extract the name of the function using an arbitrary
- -- formal's scope rather than the Name field of Call.
+ -- Examine all parameter associations of the function call
- if Access_Nam = No_Name
- and then Present (Entity (Formal))
- then
- Access_Nam :=
- New_External_Name
- (Chars (Scope (Entity (Formal))),
- BIP_Formal_Suffix (BIP_Alloc_Form));
- end if;
+ Param := First (Parameter_Associations (Call));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association
+ and then Nkind (Selector_Name (Param)) = N_Identifier
+ then
+ Formal := Selector_Name (Param);
+ Actual := Explicit_Actual_Parameter (Param);
+
+ -- Construct the name of formal BIPalloc. It is much easier to
+ -- extract the name of the function using an arbitrary formal's
+ -- scope rather than the Name field of Call.
+
+ if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
+ Alloc_Nam :=
+ New_External_Name
+ (Chars (Scope (Entity (Formal))),
+ BIP_Formal_Suffix (BIP_Alloc_Form));
+ end if;
- -- A match for BIPalloc => 2 has been found
+ -- A match for BIPalloc => 2 has been found
- if Chars (Formal) = Access_Nam
- and then Nkind (Actual) = N_Integer_Literal
- and then Intval (Actual) = Uint_2
- then
- return True;
- end if;
+ if Chars (Formal) = Alloc_Nam
+ and then Nkind (Actual) = N_Integer_Literal
+ and then Intval (Actual) = Uint_2
+ then
+ return True;
end if;
+ end if;
- Next (Param);
- end loop;
- end;
+ Next (Param);
+ end loop;
end if;
return False;
begin
return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
or else
- (Is_Private_Type (T) and then Present (Full_View (T))
- and then not Is_Tagged_Type (Full_View (T))
- and then Is_Derived_Type (Full_View (T))
- and then Etype (Full_View (T)) /= T);
+ (Is_Private_Type (T) and then Present (Full_View (T))
+ and then not Is_Tagged_Type (Full_View (T))
+ and then Is_Derived_Type (Full_View (T))
+ and then Etype (Full_View (T)) /= T);
end Is_Untagged_Derivation;
---------------------------
-- Assoc_Node must be a node in a list. Same as Insert_Action but the
-- action will be inserted after N in a manner that is compatible with
-- the transient scope mechanism.
+ --
+ -- Note: If several successive calls to Insert_Action_After are made for
+ -- the same node, they will each in turn be inserted just after the node.
+ -- This means they will end up being executed in reverse order. Use the
+ -- call to Insert_Actions_After to insert a list of actions to be executed
+ -- in the sequence in which they are given in the list.
procedure Insert_Actions_After
(Assoc_Node : Node_Id;
function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
-- Determine whether node Expr denotes a non build-in-place function call
+ function Is_Object_Access_BIP_Func_Call
+ (Expr : Node_Id;
+ Obj_Id : Entity_Id) return Boolean;
+ -- Determine if Expr denotes a build-in-place function which stores its
+ -- result in the BIPaccess actual parameter whose prefix must match Obj_Id.
+
function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-- Node N is an object reference. This function returns True if it is
-- possible that the object may not be aligned according to the normal
if Argument_Count = 0 then
Bindusg.Display;
else
- Write_Line ("try `gnatbind --help` for more information.");
+ Write_Line ("try ""gnatbind --help"" for more information.");
end if;
Exit_Program (E_Fatal);
-- Analyze the contracts of subprogram declarations, subprogram bodies
-- and variables now due to the delayed visibility requirements of their
- -- aspects.
+ -- aspects. Skip analysis if the declaration already has an error.
Decl := First (L);
while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration then
+ if Error_Posted (Decl) then
+ null;
+
+ elsif Nkind (Decl) = N_Object_Declaration then
Analyze_Object_Contract (Defining_Entity (Decl));
elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
Error_Msg_N ("within its scope, generic denotes its instance", N);
end if;
+ -- For subprograms, propagate the Intrinsic flag, to allow, e.g.
+ -- renamings and subsequent instantiations of Unchecked_Conversion.
+
+ if Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) then
+ Set_Is_Intrinsic_Subprogram
+ (New_P, Is_Intrinsic_Subprogram (Old_P));
+ end if;
+
Check_Library_Unit_Renaming (N, Old_P);
end if;
-- Print type, we used to print the Object_Definition from
-- the node, but it is much more useful to print the Etype
- -- of the defining identifier. For example, this will be a
- -- clear reference to the Itype with the bounds in the case
- -- of an unconstrained array type like String. The object
- -- after all is constrained, even if its nominal subtype is
+ -- of the defining identifier for the case where the nominal
+ -- type is an unconstrained array type. For example, this
+ -- will be a clear reference to the Itype with the bounds
+ -- in the case of a type like String. The object after
+ -- all is constrained, even if its nominal subtype is
-- unconstrained.
- Sprint_Node (Etype (Def_Id));
+ declare
+ Odef : constant Node_Id := Object_Definition (Node);
+
+ begin
+ if Nkind (Odef) = N_Identifier
+ and then Is_Array_Type (Etype (Odef))
+ and then not Is_Constrained (Etype (Odef))
+ and then Present (Etype (Def_Id))
+ then
+ Sprint_Node (Etype (Def_Id));
+
+ -- In other cases, the nominal type is fine to print
+
+ else
+ Sprint_Node (Odef);
+ end if;
+ end;
if Present (Expression (Node)) then
Write_Str (" := ");
projects / gcc.git / commitdiff