+2011-08-03 Robert Dewar <dewar@adacore.com>
+
+ * a-cfdlli.adb, bindgen.adb, exp_ch4.adb, exp_ch13.adb, sem_warn.adb,
+ exp_ch3.adb, exp_ch3.ads: Minor reformatting.
+
+2011-08-03 Pascal Obry <obry@adacore.com>
+
+ * g-awk.ads: Minor comment fix.
+
+2011-08-03 Sergey Rybin <rybin@adacore.com>
+
+ * tree_io.ads (ASIS_Version_Number): Update because of the changes in
+ the tree structure related to discriminant constraints.
+ Original_Discriminant cannot be used any more for computing the
+ defining name for the reference to a discriminant.
+
+2011-08-03 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_disp.adb (Is_Tag_Indeterminate): If the return type of the
+ function is not visibly tagged, this is not a dispatching call and
+ therfore is not Tag_Indeterminate, even if the function is marked as
+ dispatching on result.
+
2011-08-03 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch13.adb: Add with and use clauses for Restrict and Rident.
C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
N : Count_Type := 1;
P : List (C);
+
begin
while N <= Source.Capacity loop
P.Nodes (N).Prev := Source.Nodes (N).Prev;
P.Nodes (N).Element := Source.Nodes (N).Element;
N := N + 1;
end loop;
+
P.Free := Source.Free;
P.Length := Source.Length;
P.First := Source.First;
P.Last := Source.Last;
+
if P.Free >= 0 then
N := Source.Capacity + 1;
while N <= C loop
N := N + 1;
end loop;
end if;
+
return P;
end Copy;
begin
if not Has_Element (Container => Container,
- Position => Position) then
+ Position => Position)
+ then
raise Constraint_Error with
"Position cursor has no element";
end if;
"attempt to tamper with elements (list is busy)";
end if;
- for I in 1 .. Count loop
+ for J in 1 .. Count loop
X := Container.First;
pragma Assert (N (N (X).Next).Prev = Container.First);
"attempt to tamper with elements (list is busy)";
end if;
- for I in 1 .. Count loop
+ for J in 1 .. Count loop
X := Container.Last;
pragma Assert (N (N (X).Prev).Next = Container.Last);
function Element
(Container : List;
- Position : Cursor) return Element_Type is
+ Position : Cursor) return Element_Type
+ is
begin
if not Has_Element (Container => Container, Position => Position) then
raise Constraint_Error with
Position : Cursor := No_Element) return Cursor
is
From : Count_Type := Position.Node;
+
begin
if From = 0 and Container.Length = 0 then
return No_Element;
end if;
+
if From = 0 then
From := Container.First;
end if;
+
if Position.Node /= 0 and then
- not Has_Element (Container, Position) then
+ not Has_Element (Container, Position)
+ then
raise Constraint_Error with
"Position cursor has no element";
end if;
if Container.Nodes (From).Element = Item then
return (Node => From);
end if;
+
From := Container.Nodes (From).Next;
end loop;
if Container.First = 0 then
return No_Element;
end if;
+
return (Node => Container.First);
end First;
Container.Free := 0;
else
- for I in Container.Free .. Container.Capacity - 1 loop
- N (I).Next := I + 1;
+ for J in Container.Free .. Container.Capacity - 1 loop
+ N (J).Next := J + 1;
end loop;
N (Container.Capacity).Next := 0;
function Is_Sorted (Container : List) return Boolean is
Nodes : Node_Array renames Container.Nodes;
Node : Count_Type := Container.First;
+
begin
for I in 2 .. Container.Length loop
if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
---------------
procedure Partition (Pivot, Back : Count_Type) is
- Node : Count_Type := N (Pivot).Next;
+ Node : Count_Type;
begin
+ Node := N (Pivot).Next;
while Node /= Back loop
if N (Node).Element < N (Pivot).Element then
declare
if Position.Node = 0 then
return False;
end if;
+
return Container.Nodes (Position.Node).Prev /= -1;
end Has_Element;
Count : Count_Type := 1)
is
Position : Cursor;
-
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
Process (Container, (Node => Node));
Node := Container.Nodes (Node).Next;
end loop;
+
exception
when others =>
B := B - 1;
function Left (Container : List; Position : Cursor) return List is
Curs : Cursor := Position;
- C : List (Container.Capacity) := Copy (Container, Container.Capacity);
+ C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
+
begin
if Curs = No_Element then
return C;
end if;
+
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Left;
if Position.Node = 0 then
return No_Element;
end if;
+
if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element";
end if;
+
return (Node => Container.Nodes (Position.Node).Next);
end Next;
if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element";
end if;
+
return (Node => Container.Nodes (Position.Node).Prev);
end Previous;
function Right (Container : List; Position : Cursor) return List is
Curs : Cursor := First (Container);
- C : List (Container.Capacity) := Copy (Container, Container.Capacity);
+ C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
+
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
+
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
+
return C;
end Right;
function Strict_Equal (Left, Right : List) return Boolean is
CL : Count_Type := Left.First;
CR : Count_Type := Right.First;
+
begin
while CL /= 0 or CR /= 0 loop
if CL /= CR or else
- Left.Nodes (CL).Element /= Right.Nodes (CL).Element then
+ Left.Nodes (CL).Element /= Right.Nodes (CL).Element
+ then
return False;
end if;
+
CL := Left.Nodes (CL).Next;
CR := Right.Nodes (CR).Next;
end loop;
+
return True;
end Strict_Equal;
I, J : Cursor)
is
begin
-
if I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
I_Next, J_Next : Cursor;
begin
-
if I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
Process : not null access procedure (Element : in out Element_Type))
is
begin
-
if Position.Node = 0 then
raise Constraint_Error with "Position cursor has no element";
end if;
procedure Gen_Main_C is
Needs_Library_Finalization : constant Boolean :=
- not Configurable_Run_Time_On_Target and then Has_Finalizer;
+ not Configurable_Run_Time_On_Target
+ and then Has_Finalizer;
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want library-level finalization.
-- function Get_Ada_Main_Name for details on the form of the name.
Needs_Library_Finalization : constant Boolean :=
- not Configurable_Run_Time_On_Target and then Has_Finalizer;
+ not Configurable_Run_Time_On_Target
+ and then Has_Finalizer;
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want finalization.
procedure Gen_Output_File_C (Filename : String) is
Needs_Library_Finalization : constant Boolean :=
- not Configurable_Run_Time_On_Target and then Has_Finalizer;
+ not Configurable_Run_Time_On_Target
+ and then Has_Finalizer;
+ -- ??? seems like we repeat this cantation often, should it be global?
Bfile : Name_Id;
pragma Warnings (Off, Bfile);
procedure Expand_N_Free_Statement (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
- Typ : Entity_Id := Etype (Expr);
+ Typ : Entity_Id;
begin
-- Certain run-time configurations and targets do not provide support
-- Use the base type to perform the collection check
+ Typ := Etype (Expr);
+
if Ekind (Typ) = E_Access_Subtype then
Typ := Etype (Typ);
end if;
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition =>
+ Constant_Present => True,
+ Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
- Expression =>
+ Expression =>
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
Append_To (Res,
- Make_Init_Call (
- Obj_Ref => New_Copy_Tree (First_Arg),
- Typ => Typ));
+ Make_Init_Call
+ (Obj_Ref => New_Copy_Tree (First_Arg),
+ Typ => Typ));
end if;
end if;
then
Exp :=
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access);
end if;
then
Append_To (Res,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ), Loc)),
and then not Is_Immutably_Limited_Type (Typ)
then
Append_To (Res,
- Make_Adjust_Call (
- Obj_Ref => New_Copy_Tree (Lhs),
- Typ => Etype (Id)));
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Lhs),
+ Typ => Etype (Id)));
end if;
return Res;
Res :=
New_List (
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (Parent_Proc, Loc),
Parameter_Associations => Args));
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
- In_Present => True,
- Parameter_Type =>
+ In_Present => True,
+ Parameter_Type =>
New_Reference_To (Rec_Type, Loc))));
Set_Result_Definition (Spec_Node,
New_Reference_To (RTE (RE_Storage_Offset), Loc));
Set_Declarations (Body_Node, New_List);
Set_Handled_Statement_Sequence (Body_Node,
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
+ Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Counter_Id, Loc),
+ Name => New_Reference_To (Counter_Id, Loc),
Expression =>
Make_Op_Add (Loc,
- Left_Opnd =>
- New_Reference_To (Counter_Id, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 1))));
+ Left_Opnd => New_Reference_To (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))));
end Increment_Counter;
------------------
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
- Object_Definition =>
+ Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
- Expression =>
+ Expression =>
Make_Integer_Literal (Loc, 0)));
end Make_Counter;
Build_Initialization_Call
(Loc,
Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- New_Occurrence_Of (Id, Loc)),
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
if Restricted_Profile then
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uATCB)),
De := First_Discriminant (Rec_Ent);
Dp := First_Discriminant (Etype (Rec_Ent));
-
while Present (De) loop
pragma Assert (Present (Dp));
or else not Comes_From_Source (N)
then
Insert_Action_After (Init_After,
- Make_Init_Call (
- Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Type (Typ)));
+ Make_Init_Call
+ (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+ Typ => Base_Type (Typ)));
-- Abort allowed
declare
L : constant List_Id := New_List (
- Make_Init_Call (
- Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Type (Typ)));
+ Make_Init_Call
+ (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
+ Typ => Base_Type (Typ)));
Blk : constant Node_Id :=
Make_Block_Statement (Loc,
declare
Init_Expr : constant Node_Id :=
Static_Initialization (Base_Init_Proc (Typ));
+
begin
if Present (Init_Expr) then
Set_Expression
(N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
return;
+
else
Initialization_Warning (Id_Ref);
null;
elsif (Needs_Finalization (Desig_Type)
- and then Convention (Desig_Type) /= Convention_Java
- and then Convention (Desig_Type) /= Convention_CIL)
+ and then Convention (Desig_Type) /= Convention_Java
+ and then Convention (Desig_Type) /= Convention_CIL)
or else
(Is_Incomplete_Or_Private_Type (Desig_Type)
- and then No (Full_View (Desig_Type))
+ and then No (Full_View (Desig_Type))
-- An exception is made for types defined in the run-time
-- because Ada.Tags.Tag itself is such a type and cannot
or else
(Is_Array_Type (Desig_Type)
- and then not Is_Frozen (Desig_Type)
- and then Needs_Finalization (Component_Type (Desig_Type)))
+ and then not Is_Frozen (Desig_Type)
+ and then Needs_Finalization (Component_Type (Desig_Type)))
then
Build_Finalization_Collection (Def_Id);
end if;
Formals := New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_V),
- In_Present => True,
- Out_Present => True,
- Parameter_Type =>
- New_Reference_To (Tag_Typ, Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type => New_Reference_To (Tag_Typ, Loc)));
-- F : Boolean := True
then
Append_To (Formals,
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_F),
- Parameter_Type =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_True, Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
+ Parameter_Type => New_Reference_To (Standard_Boolean, Loc),
+ Expression => New_Reference_To (Standard_True, Loc)));
end if;
return
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile,
- Result_Definition =>
- New_Reference_To (Ret_Type, Loc));
+ Result_Definition => New_Reference_To (Ret_Type, Loc));
end if;
if Is_Interface (Tag_Typ) then
Ret_Type := Empty;
end if;
- return Predef_Spec_Or_Body (Loc,
- Name => Make_TSS_Name (Tag_Typ, Name),
- Tag_Typ => Tag_Typ,
- Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
- Ret_Type => Ret_Type,
- For_Body => For_Body);
+ return
+ Predef_Spec_Or_Body
+ (Loc,
+ Name => Make_TSS_Name (Tag_Typ, Name),
+ Tag_Typ => Tag_Typ,
+ Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
+ Ret_Type => Ret_Type,
+ For_Body => For_Body);
end Predef_Stream_Attr_Spec;
---------------------------------
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
- Make_Final_Call (
- Obj_Ref => Make_Identifier (Loc, Name_V),
- Typ => Tag_Typ))));
+ Make_Final_Call
+ (Obj_Ref => Make_Identifier (Loc, Name_V),
+ Typ => Tag_Typ))));
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Null_Statement (Loc))));
+ Statements => New_List (Make_Null_Statement (Loc))));
end if;
Append_To (Res, Decl);
function Predefined_Primitive_Freeze
(Tag_Typ : Entity_Id) return List_Id
is
- Res : constant List_Id := New_List;
+ Res : constant List_Id := New_List;
Prim : Elmt_Id;
Frnodes : List_Id;
-- want Gigi to see the node. This function can't delete the node itself
-- since it would confuse any remaining processing of the freeze node.
- function Get_Simple_Init_Val
- (T : Entity_Id;
- N : Node_Id;
- Size : Uint := No_Uint) return Node_Id;
- -- For a type which Needs_Simple_Initialization (see above), prepares the
- -- tree for an expression representing the required initial value. N is a
- -- node whose source location used in constructing this tree which is
- -- returned as the result of the call. The Size parameter indicates the
- -- target size of the object if it is known (indicated by a value that is
- -- not No_Uint and is greater than zero). If Size is not given (Size set to
- -- No_Uint, or non-positive), then the Esize of T is used as an estimate of
- -- the Size. The object size is needed to prepare a known invalid value for
- -- use by Normalize_Scalars. A call to this routine where T is a scalar
- -- type is only valid if we are in Normalize_Scalars or Initialize_Scalars
- -- mode, or if N is the node for a 'Invalid_Value attribute node.
-
procedure Init_Secondary_Tags
(Typ : Entity_Id;
Target : Node_Id;
-- set to False, but if Consider_IS is set to True, then the cases above
-- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
+ function Get_Simple_Init_Val
+ (T : Entity_Id;
+ N : Node_Id;
+ Size : Uint := No_Uint) return Node_Id;
+ -- For a type which Needs_Simple_Initialization (see above), prepares the
+ -- tree for an expression representing the required initial value. N is a
+ -- node whose source location used in constructing this tree which is
+ -- returned as the result of the call. The Size parameter indicates the
+ -- target size of the object if it is known (indicated by a value that is
+ -- not No_Uint and is greater than zero). If Size is not given (Size set to
+ -- No_Uint, or non-positive), then the Esize of T is used as an estimate of
+ -- the Size. The object size is needed to prepare a known invalid value for
+ -- use by Normalize_Scalars. A call to this routine where T is a scalar
+ -- type is only valid if we are in Normalize_Scalars or Initialize_Scalars
+ -- mode, or if N is the node for a 'Invalid_Value attribute node.
+
end Exp_Ch3;
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Build_Get_Access_Level (Loc,
Make_Attribute_Reference (Loc,
- Prefix => Ref_Node,
+ Prefix => Ref_Node,
Attribute_Name => Name_Tag)),
Right_Opnd =>
- Make_Integer_Literal (Loc,
- Type_Access_Level (PtrT))),
+ Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
Reason => PE_Accessibility_Check_Failed));
end if;
end Apply_Accessibility_Check;
New_Decl :=
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'P'),
- Object_Definition =>
- New_Reference_To (PtrT, Loc),
- Expression =>
+ Defining_Identifier => Make_Temporary (Loc, 'P'),
+ Object_Definition => New_Reference_To (PtrT, Loc),
+ Expression =>
Unchecked_Convert_To (PtrT,
New_Reference_To (Temp, Loc)));
and then Present (Associated_Collection (PtrT))
then
Insert_Action (N,
- Make_Set_Finalize_Address_Ptr_Call (
- Loc => Loc,
- Typ => T,
- Ptr_Typ => PtrT));
+ Make_Set_Finalize_Address_Ptr_Call
+ (Loc => Loc,
+ Typ => T,
+ Ptr_Typ => PtrT));
end if;
end if;
Object_Definition => New_Reference_To (PtrT, Loc),
Expression =>
Make_Allocator (Loc,
- Expression =>
- New_Reference_To (Etype (Exp), Loc)));
+ Expression => New_Reference_To (Etype (Exp), Loc)));
-- Copy the Comes_From_Source flag for the allocator we just built,
-- since logically this allocator is a replacement of the original
and then Present (Associated_Collection (PtrT))
then
Insert_Action (N,
- Make_Attach_Call (
- Obj_Ref =>
- New_Reference_To (Temp, Loc),
- Ptr_Typ => PtrT));
+ Make_Attach_Call
+ (Obj_Ref => New_Reference_To (Temp, Loc),
+ Ptr_Typ => PtrT));
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
Insert_Action (Exp,
Make_Subtype_Declaration (Loc,
Defining_Identifier => ConstrT,
- Subtype_Indication =>
- Make_Subtype_From_Expr (Exp, T)));
+ Subtype_Indication => Make_Subtype_From_Expr (Exp, T)));
Freeze_Itype (ConstrT, Exp);
Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
end;
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Etyp, Loc));
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (Etyp, Loc));
if Nkind (Expression (N)) = N_Qualified_Expression then
Set_Expression (Temp_Decl, Expression (Expression (N)));
Rewrite (N,
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Temp_Id, Loc),
+ Prefix => New_Occurrence_Of (Temp_Id, Loc),
Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT);
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Name_Length,
- Expressions => New_List (
- Make_Integer_Literal (Loc, J)));
+ Expressions => New_List (Make_Integer_Literal (Loc, J)));
if J = 1 then
Res := Len;
if Is_Access_Constant (PtrT)
and then Nkind (Expression (N)) = N_Qualified_Expression
and then Compile_Time_Known_Value (Expression (Expression (N)))
- and then Size_Known_At_Compile_Time (Etype (Expression
- (Expression (N))))
+ and then Size_Known_At_Compile_Time
+ (Etype (Expression (Expression (N))))
and then not Is_Record_Type (Current_Scope)
then
-- Here we can do the optimization. For the allocator
Rewrite (N,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Temp, Loc),
+ Prefix => New_Occurrence_Of (Temp, Loc),
Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT);
Make_Op_Gt (Loc,
Left_Opnd => Size_In_Storage_Elements (Etyp),
Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => Uint_7 * (Uint_2 ** 29))),
+ Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
Reason => SE_Object_Too_Large));
end if;
end if;
-- type whose definition is a concurrent type, the first
-- argument in the Init routine has to be unchecked conversion
-- to the corresponding record type. If the designated type is
- -- a derived type, we also convert the argument to its root
- -- type.
+ -- a derived type, also convert the argument to its root type.
if Is_Concurrent_Type (T) then
Init_Arg1 :=
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
- elsif Nkind_In
- (Nam, N_Indexed_Component, N_Selected_Component)
+ elsif Nkind_In (Nam, N_Indexed_Component,
+ N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam))
then
Decls :=
else
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Init, Loc),
+ Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args));
end if;
-- [Deep_]Initialize (Init_Arg1);
Insert_Action (N,
- Make_Init_Call (
- Obj_Ref => New_Copy_Tree (Init_Arg1),
- Typ => T));
+ Make_Init_Call
+ (Obj_Ref => New_Copy_Tree (Init_Arg1),
+ Typ => T));
if Present (Associated_Collection (PtrT)) then
if VM_Target /= No_VM then
if Is_Controlled (T) then
Insert_Action (N,
- Make_Attach_Call (
- Obj_Ref => New_Copy_Tree (Init_Arg1),
- Ptr_Typ => PtrT));
+ Make_Attach_Call
+ (Obj_Ref => New_Copy_Tree (Init_Arg1),
+ Ptr_Typ => PtrT));
end if;
-- Default case, generate:
else
Insert_Action (N,
- Make_Set_Finalize_Address_Ptr_Call (
- Loc => Loc,
- Typ => T,
- Ptr_Typ => PtrT));
+ Make_Set_Finalize_Address_Ptr_Call
+ (Loc => Loc,
+ Typ => T,
+ Ptr_Typ => PtrT));
end if;
end if;
end if;
Make_Temporary (Loc, 'A'),
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Reference_To (Typ, Loc)));
+ All_Present => True,
+ Subtype_Indication => New_Reference_To (Typ, Loc)));
Insert_Action (N, P_Decl);
Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx),
- Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
+ Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Expression =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
- Prefix => Relocate_Node (Thenx)))),
+ Prefix => Relocate_Node (Thenx)))),
Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex),
- Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
+ Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
- Prefix => Relocate_Node (Elsex)))));
+ Prefix => Relocate_Node (Elsex)))));
New_N :=
Make_Explicit_Dereference (Loc,
Result := New_Reference_To (Standard_True, Loc);
C := Suitable_Element (First_Entity (Typ));
-
while Present (C) loop
declare
New_Lhs : Node_Id;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2010, AdaCore --
+-- Copyright (C) 2000-2011, AdaCore --
-- --
-- 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- --
-- a full AWK run. The state comprises a list of files, the current file,
-- the number of line processed, the current line, the number of fields in
-- the current line... A default session is provided (see Set_Current,
- -- Current_Session and Default_Session above).
+ -- Current_Session and Default_Session below).
----------------------------
-- Package initialization --
if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
- -- If Old_Subp isn't already marked as dispatching then
- -- this is the case of an operation of an untagged private
- -- type fulfilled by a tagged type that overrides an
- -- inherited dispatching operation, so we set the necessary
- -- dispatching attributes here.
+ -- If Old_Subp isn't already marked as dispatching then this is
+ -- the case of an operation of an untagged private type fulfilled
+ -- by a tagged type that overrides an inherited dispatching
+ -- operation, so we set the necessary dispatching attributes here.
if not Is_Dispatching_Operation (Old_Subp) then
-- If the untagged type has no discriminants, and the full
- -- view is constrained, there will be a spurious mismatch
- -- of subtypes on the controlling arguments, because the tagged
+ -- view is constrained, there will be a spurious mismatch of
+ -- subtypes on the controlling arguments, because the tagged
-- type is the internal base type introduced in the derivation.
-- Use the original type to verify conformance, rather than the
-- base type.
begin
-- The original corresponding operation of Prim must be an
- -- operation of a visible ancestor of the dispatching type
- -- S, and the original corresponding operation of S2 must
- -- be visible.
+ -- operation of a visible ancestor of the dispatching type S,
+ -- and the original corresponding operation of S2 must be
+ -- visible.
Orig_Prim := Original_Corresponding_Operation (Prim);
if not Has_Controlling_Result (Nam) then
return False;
+ -- The function may have a controlling result, but if the return type
+ -- is not visibly tagged, then this is not tag-indeterminate.
+
+ elsif Is_Access_Type (Etype (Nam))
+ and then not Is_Tagged_Type (Designated_Type (Etype (Nam)))
+ then
+ return False;
+
-- An explicit dereference means that the call has already been
-- expanded and there is no tag to propagate.
if Is_Controlling_Actual (Actual)
and then not Is_Tag_Indeterminate (Actual)
then
- return False; -- one operand is dispatching
+ -- One operand is dispatching
+
+ return False;
end if;
Next_Actual (Actual);
then
return True;
- -- In Ada 2005 a function that returns an anonymous access type can
- -- dispatching, and the dereference of a call to such a function
- -- is also tag-indeterminate.
+ -- In Ada 2005, a function that returns an anonymous access type can be
+ -- dispatching, and the dereference of a call to such a function can
+ -- also be tag-indeterminate if the call itself is.
elsif Nkind (Orig_Node) = N_Explicit_Dereference
and then Ada_Version >= Ada_2005
Act1, Form);
else
-
-- For greater clarity, give name of formal.
Error_Msg_Node_2 := Form;
Tree_Format_Error : exception;
-- Raised if a format error is detected in the input file
- ASIS_Version_Number : constant := 24;
+ ASIS_Version_Number : constant := 25;
-- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees and an ASIS application that is reading the
-- trees. It must be incremented whenever a change is made to the tree
projects / gcc.git / commitdiff