+2011-08-04 Robert Dewar <dewar@adacore.com>
+
+ * par_sco.adb, prj-proc.adb, make.adb, bindgen.adb, prj.adb, prj.ads,
+ makeutl.adb, makeutl.ads, prj-nmsc.adb, exp_ch5.adb, exp_ch12.adb,
+ exp_ch7.ads, exp_util.ads, sem_util.ads, g-comlin.ads, exp_ch6.adb,
+ exp_ch6.ads, lib-xref.ads, exp_ch7.adb, exp_util.adb, exp_dist.adb,
+ exp_strm.adb, gnatcmd.adb, freeze.adb, g-comlin.adb, lib-xref-alfa.adb,
+ sem_attr.adb, sem_prag.adb, sem_util.adb, sem_elab.adb, sem_ch8.adb,
+ sem_ch11.adb, sem_eval.adb, sem_ch13.adb, sem_disp.adb, a-fihema.adb:
+ Minor reformatting and code reorganization.
+
+2011-08-04 Emmanuel Briot <briot@adacore.com>
+
+ * projects.texi: Added doc for aggregate projects.
+
2011-08-04 Emmanuel Briot <briot@adacore.com>
* prj-proc.adb, prj-nmsc.adb, prj-env.adb (Process_Declarative_Items):
Header_Size : constant Storage_Count := Node'Size / Storage_Unit;
Header_Offset : constant Storage_Offset := Header_Size;
+ -- Comments needed???
function Address_To_Node_Ptr is
new Ada.Unchecked_Conversion (Address, Node_Ptr);
N.Prev := L;
Unlock_Task.all;
+
exception
when others =>
Unlock_Task.all;
end if;
Unlock_Task.all;
+
exception
when others =>
Unlock_Task.all;
if U.Set_Elab_Entity
- -- Don't generate reference for stand alone library
+ -- Don't generate reference for stand alone library
and then not U.SAL_Interface
- -- Don't generate reference for predefined file in No_Run_Time
- -- mode, since we don't include the object files in this case
+ -- Don't generate reference for predefined file in No_Run_Time
+ -- mode, since we don't include the object files in this case
and then not
(No_Run_Time_Mode
- and then Is_Predefined_File_Name (U.Sfile))
+ and then Is_Predefined_File_Name (U.Sfile))
then
Set_String (" ");
Set_String ("E");
if U.Set_Elab_Entity
- -- Don't generate reference for stand alone library
+ -- Don't generate reference for stand alone library
and then not U.SAL_Interface
- -- Don't generate reference for predefined file in No_Run_Time
- -- mode, since we don't include the object files in this case
+ -- Don't generate reference for predefined file in No_Run_Time
+ -- mode, since we don't include the object files in this case
and then not
(No_Run_Time_Mode
- and then Is_Predefined_File_Name (U.Sfile))
+ and then Is_Predefined_File_Name (U.Sfile))
then
Set_String ("extern int ");
Get_Name_String (U.Uname);
-- since it will be done when we process the body.
else
- if Force_Checking_Of_Elaboration_Flags or
- Interface_Library_Unit or
- (not Bind_Main_Program)
+ if Force_Checking_Of_Elaboration_Flags
+ or Interface_Library_Unit
+ or not Bind_Main_Program
then
Set_String (" if E");
Set_Unit_Number (Unum_Spec);
Set_Char (';');
Write_Statement_Buffer;
- if Force_Checking_Of_Elaboration_Flags or
- Interface_Library_Unit or
- (not Bind_Main_Program)
+ if Force_Checking_Of_Elaboration_Flags
+ or Interface_Library_Unit
+ or not Bind_Main_Program
then
WBI (" end if;");
end if;
else
Get_Name_String (U.Uname);
- if Force_Checking_Of_Elaboration_Flags or
- Interface_Library_Unit or
- (not Bind_Main_Program)
+ if Force_Checking_Of_Elaboration_Flags
+ or Interface_Library_Unit
+ or not Bind_Main_Program
then
Set_String (" if (");
Set_Unit_Name;
Set_String (" - 1;");
Write_Statement_Buffer;
- if Interface_Library_Unit or (not Bind_Main_Program) then
+ if Interface_Library_Unit or not Bind_Main_Program then
Set_String (" if E");
Set_Unit_Number (Unum);
Set_String (" = 0 then");
Set_Char (';');
Write_Statement_Buffer;
- if Interface_Library_Unit or (not Bind_Main_Program) then
+ if Interface_Library_Unit or not Bind_Main_Program then
WBI (" end if;");
end if;
Set_String ("_E--;");
Write_Statement_Buffer;
- if Interface_Library_Unit or (not Bind_Main_Program) then
+ if Interface_Library_Unit or not Bind_Main_Program then
Set_String (" if (");
Set_Unit_Name;
Set_String ("_E == 0)");
-- If not spec that has an associated body, then generate a comment
-- giving the name of the corresponding object file.
- if (not Units.Table (Elab_Order.Table (E)).SAL_Interface)
+ if not Units.Table (Elab_Order.Table (E)).SAL_Interface
and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
then
Get_Name_String
WBI (" type Version_32 is mod 2 ** 32;");
for U in Units.First .. Units.Last loop
- if not Units.Table (U).SAL_Interface and then
- ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
+ if not Units.Table (U).SAL_Interface
+ and then
+ (not Bind_For_Library or else Units.Table (U).Directly_Scanned)
then
Increment_Ubuf;
WBI (" " & Ubuf & " : constant Version_32 := 16#" &
procedure Gen_Versions_C is
begin
for U in Units.First .. Units.Last loop
- if not Units.Table (U).SAL_Interface and then
- ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
+ if not Units.Table (U).SAL_Interface
+ and then
+ (not Bind_For_Library or else Units.Table (U).Directly_Scanned)
then
Set_String ("unsigned ");
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
- Prefix => New_Occurrence_Of (Ent, Loc))),
+ Prefix => New_Occurrence_Of (Ent, Loc))),
Reason => PE_Access_Before_Elaboration));
end if;
end Expand_N_Generic_Instantiation;
else
Append_To (Res,
- Make_Final_Call (
- Obj_Ref => Duplicate_Subexpr_No_Checks (L),
- Typ => Etype (L)));
+ Make_Final_Call
+ (Obj_Ref => Duplicate_Subexpr_No_Checks (L),
+ Typ => Etype (L)));
end if;
-- Save the Tag in a local variable Tag_Id
Append_To (Res,
Make_Object_Declaration (Loc,
Defining_Identifier => Tag_Id,
- Object_Definition =>
- New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks (L),
+ Prefix => Duplicate_Subexpr_No_Checks (L),
Selector_Name =>
New_Reference_To (First_Tag_Component (T), Loc))));
Append_To (Res,
Make_Object_Declaration (Loc,
Defining_Identifier => Prev_Id,
- Object_Definition =>
+ Object_Definition =>
New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
- Expression =>
+ Expression =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To
(RTE (RE_Root_Controlled), New_Copy_Tree (L)),
Selector_Name =>
Append_To (Res,
Make_Object_Declaration (Loc,
Defining_Identifier => Next_Id,
- Object_Definition =>
+ Object_Definition =>
New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
- Expression =>
+ Expression =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To
(RTE (RE_Root_Controlled), New_Copy_Tree (L)),
Selector_Name =>
if Save_Tag then
Append_To (Res,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks (L),
+ Prefix => Duplicate_Subexpr_No_Checks (L),
Selector_Name =>
New_Reference_To (First_Tag_Component (T), Loc)),
- Expression =>
- New_Reference_To (Tag_Id, Loc)));
+ Expression => New_Reference_To (Tag_Id, Loc)));
end if;
-- Restore the Prev and Next fields on .NET/JVM
Append_To (Res,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To
(RTE (RE_Root_Controlled), New_Copy_Tree (L)),
Selector_Name =>
Make_Identifier (Loc, Name_Prev)),
- Expression =>
- New_Reference_To (Prev_Id, Loc)));
+ Expression => New_Reference_To (Prev_Id, Loc)));
-- Generate:
-- Root_Controlled (L).Next := Next_Id;
Append_To (Res,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To
(RTE (RE_Root_Controlled), New_Copy_Tree (L)),
- Selector_Name =>
- Make_Identifier (Loc, Name_Next)),
- Expression =>
- New_Reference_To (Next_Id, Loc)));
+ Selector_Name => Make_Identifier (Loc, Name_Next)),
+ Expression => New_Reference_To (Next_Id, Loc)));
end if;
-- Adjust the target after the assignment when controlled (not in the
if Ctrl_Act then
Append_To (Res,
- Make_Adjust_Call (
- Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
- Typ => Etype (L)));
+ Make_Adjust_Call
+ (Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
+ Typ => Etype (L)));
end if;
return Res;
exception
+
-- Could use comment here ???
when RE_Not_Available =>
-- called.
function Is_Direct_Deep_Call (Subp : Entity_Id) return Boolean;
- -- Determine whether Subp denotes a non-dispatching call to a Deep
- -- routine.
+ -- Determine if Subp denotes a non-dispatching call to a Deep routine
function New_Value (From : Node_Id) return Node_Id;
-- From is the original Expression. New_Value is equivalent to a call
Append_To (Decls,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Pool_Id,
- Subtype_Mark =>
+ Subtype_Mark =>
New_Reference_To (RTE (RE_Root_Storage_Pool), Loc),
- Name =>
+ Name =>
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Base_Pool), Loc),
-
Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Reference_To (Collect, Loc)))))));
+ Prefix => New_Reference_To (Collect, Loc)))))));
-- Create an access type which uses the storage pool of the
-- caller's collection. This additional type is necessary
Append_To (Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Typ,
- Type_Definition =>
+ Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Reference_To (Ret_Typ, Loc))));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Id,
- Object_Definition =>
+ Object_Definition =>
New_Reference_To (Ptr_Typ, Loc)));
-- Allocate the object, generate:
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Local_Id, Loc),
+ Name => New_Reference_To (Local_Id, Loc),
Expression => Alloc_Expr));
-- Generate:
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Temp_Id, Loc),
+ Name => New_Reference_To (Temp_Id, Loc),
Expression =>
Unchecked_Convert_To (Temp_Typ,
New_Reference_To (Local_Id, Loc))));
return
Make_If_Statement (Loc,
- Condition =>
+ Condition =>
Make_Op_Ne (Loc,
- Left_Opnd =>
- New_Reference_To (Collect, Loc),
- Right_Opnd =>
- Make_Null (Loc)),
+ Left_Opnd => New_Reference_To (Collect, Loc),
+ Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
Make_Block_Statement (Loc,
- Declarations => Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts))));
else
return
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Temp_Id, Loc),
+ Name => New_Reference_To (Temp_Id, Loc),
Expression => Alloc_Expr);
end if;
end Build_Heap_Allocator;
return
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Move_Activation_Chain), Loc),
Parameter_Associations => New_List (From, To, New_Master));
end Move_Activation_Chain;
Flag_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Flag_Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc));
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression => New_Reference_To (Standard_False, Loc));
Prepend_To (Declarations (Func_Bod), Flag_Decl);
Analyze (Flag_Decl);
else
Stmts := New_List (
Make_Block_Statement (Loc,
- Declarations => New_List,
+ Declarations => New_List,
Handled_Statement_Sequence => HSS));
end if;
-- the case of result types with task parts.
if Is_Build_In_Place
- and Has_Task (Etype (Par_Func))
+ and then Has_Task (Etype (Par_Func))
then
Append_To (Stmts, Move_Activation_Chain);
end if;
Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Flag_Id, Loc),
- Expression =>
- New_Reference_To (Standard_True, Loc)));
+ Name => New_Reference_To (Flag_Id, Loc),
+ Expression => New_Reference_To (Standard_True, Loc)));
end;
end if;
Return_Stmt :=
Make_Simple_Return_Statement (Loc,
- Expression =>
- New_Occurrence_Of (Ret_Obj_Id, Loc));
+ Expression => New_Occurrence_Of (Ret_Obj_Id, Loc));
Append_To (Stmts, Return_Stmt);
HSS := Make_Handled_Sequence_Of_Statements (Loc, Stmts);
if Present (HSS) then
Result :=
Make_Block_Statement (Loc,
- Declarations => Return_Object_Declarations (N),
+ Declarations => Return_Object_Declarations (N),
Handled_Statement_Sequence => HSS);
-- We set the entity of the new block statement to be that of the
then
pragma Assert
(Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
- and then Is_Build_In_Place_Function_Call
- (Expression (Original_Node (Ret_Obj_Decl))));
+ and then Is_Build_In_Place_Function_Call
+ (Expression (Original_Node (Ret_Obj_Decl))));
-- Return the build-in-place result by reference
then
Init_Assignment :=
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Return_Obj_Id, Loc),
- Expression =>
- Relocate_Node (Return_Obj_Expr));
+ Name => New_Reference_To (Return_Obj_Id, Loc),
+ Expression => Relocate_Node (Return_Obj_Expr));
Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id));
Set_Assignment_OK (Name (Init_Assignment));
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Etype (Return_Obj_Id), Loc),
- Expression =>
+ Expression =>
Relocate_Node (Expression (Init_Assignment))));
end if;
Ptr_Type_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ref_Type,
- Type_Definition =>
+ Type_Definition =>
Make_Access_To_Object_Definition (Loc,
- All_Present => True,
+ All_Present => True,
Subtype_Indication =>
New_Reference_To (Return_Obj_Typ, Loc)));
Alloc_Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Alloc_Obj_Id,
- Object_Definition =>
+ Object_Definition =>
New_Reference_To (Ref_Type, Loc));
Insert_Before (Ret_Obj_Decl, Alloc_Obj_Decl);
Subtype_Mark =>
New_Reference_To
(Etype (Return_Obj_Expr), Loc),
- Expression =>
+ Expression =>
New_Copy_Tree (Return_Obj_Expr)));
else
Make_If_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd =>
+ Left_Opnd =>
New_Reference_To (Obj_Alloc_Formal, Loc),
Right_Opnd =>
Make_Integer_Literal (Loc,
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (Alloc_Obj_Id, Loc),
Expression =>
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Reference_To (Ref_Type, Loc),
- Expression =>
+ Expression =>
New_Reference_To (Object_Access, Loc)))),
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd =>
+ Left_Opnd =>
New_Reference_To (Obj_Alloc_Formal, Loc),
Right_Opnd =>
Make_Integer_Literal (Loc,
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (Alloc_Obj_Id, Loc),
Expression => SS_Allocator)))),
if Present (Init_Assignment) then
Rewrite (Name (Init_Assignment),
Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Reference_To (Alloc_Obj_Id, Loc)));
+ Prefix => New_Reference_To (Alloc_Obj_Id, Loc)));
Set_Etype
(Name (Init_Assignment), Etype (Return_Obj_Id));
Append_To
- (Then_Statements (Alloc_If_Stmt),
- Init_Assignment);
+ (Then_Statements (Alloc_If_Stmt), Init_Assignment);
end if;
Insert_Before (Ret_Obj_Decl, Alloc_If_Stmt);
Obj_Acc_Deref :=
Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Reference_To (Object_Access, Loc));
+ Prefix => New_Reference_To (Object_Access, Loc));
Rewrite (Ret_Obj_Decl,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Return_Obj_Id,
- Access_Definition => Empty,
- Subtype_Mark =>
+ Access_Definition => Empty,
+ Subtype_Mark =>
New_Occurrence_Of (Return_Obj_Typ, Loc),
- Name => Obj_Acc_Deref));
+ Name => Obj_Acc_Deref));
Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref);
end;
and then not Comes_From_Source (Parent (S))
then
Loc := Sloc (Last_Stm);
-
elsif Present (End_Label (H)) then
Loc := Sloc (End_Label (H));
-
else
Loc := Sloc (Last_Stm);
end if;
Set_Declarations (N, Empty_List);
Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Null_Statement (Loc))));
+ Statements => New_List (Make_Null_Statement (Loc))));
return;
end if;
end if;
New_Reference_To (RTE (RE_Complete_Entry_Body), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Reference_To
(Find_Protection_Object (Current_Scope), Loc),
- Attribute_Name =>
- Name_Unchecked_Access)));
+ Attribute_Name => Name_Unchecked_Access)));
Insert_Before (N, Call);
Analyze (Call);
Decls := New_List (
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Obj_Ptr,
- Type_Definition =>
+ Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Reference_To
Rec :=
Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (Obj_Ptr,
- New_Occurrence_Of (Param, Loc)));
+ Prefix =>
+ Unchecked_Convert_To (Obj_Ptr,
+ New_Occurrence_Of (Param, Loc)));
-- Analyze new actual. Other actuals in calls are already analyzed
-- and the list of actuals is not reanalyzed after rewriting.
Rec : Node_Id;
begin
- -- If the protected object is not an enclosing scope, this is
- -- an inter-object function call. Inter-object procedure
- -- calls are expanded by Exp_Ch9.Build_Simple_Entry_Call.
- -- The call is intra-object only if the subprogram being
- -- called is in the protected body being compiled, and if the
- -- protected object in the call is statically the enclosing type.
- -- The object may be an component of some other data structure,
- -- in which case this must be handled as an inter-object call.
+ -- If the protected object is not an enclosing scope, this is an
+ -- inter-object function call. Inter-object procedure calls are expanded
+ -- by Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if
+ -- the subprogram being called is in the protected body being compiled,
+ -- and if the protected object in the call is statically the enclosing
+ -- type. The object may be an component of some other data structure, in
+ -- which case this must be handled as an inter-object call.
if not In_Open_Scopes (Scop)
or else not Is_Entity_Name (Name (N))
end if;
Build_Protected_Subprogram_Call (N,
- Name => New_Occurrence_Of (Subp, Sloc (N)),
- Rec => Convert_Concurrent (Rec, Etype (Rec)),
+ Name => New_Occurrence_Of (Subp, Sloc (N)),
+ Rec => Convert_Concurrent (Rec, Etype (Rec)),
External => True);
else
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name => Make_Identifier (Loc, Name_uTag)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Base_Type (Utyp), Loc),
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Utyp), Loc),
Attribute_Name => Name_Tag)),
- Reason => CE_Tag_Check_Failed));
+ Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type, then we
-- have to ensure that the tag of the result is that of the result
or else Nkind_In (Exp, N_Type_Conversion,
N_Unchecked_Type_Conversion)
or else (Is_Entity_Name (Exp)
- and then Ekind (Entity (Exp)) in Formal_Kind)
+ and then Ekind (Entity (Exp)) in Formal_Kind)
or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
then
then
Tag_Node :=
Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address),
- Duplicate_Subexpr (Prefix (Exp)))))));
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr (Prefix (Exp)))))));
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Exp),
+ Prefix => Duplicate_Subexpr (Exp),
Attribute_Name => Name_Tag);
end if;
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
- Left_Opnd =>
- Build_Get_Access_Level (Loc, Tag_Node),
+ Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node),
Right_Opnd =>
Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
Constant_Present => True,
Object_Definition => New_Occurrence_Of (R_Type, Loc),
Expression => ExpR),
- Suppress => All_Checks);
+ Suppress => All_Checks);
Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
end;
end if;
N_Integer_Literal,
N_Real_Literal)
or else (Nkind (Exp) = N_Explicit_Dereference
- and then Is_Entity_Name (Prefix (Exp)))
+ and then Is_Entity_Name (Prefix (Exp)))
then
null;
Ptr_Typ_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Typ,
- Type_Definition =>
+ Type_Definition =>
Make_Access_To_Object_Definition (Loc,
- All_Present => True,
+ All_Present => True,
Subtype_Indication =>
New_Reference_To (Result_Subt, Loc)));
Insert_After_And_Analyze (Assign, Ptr_Typ_Decl);
Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Obj_Id,
- Object_Definition =>
- New_Reference_To (Ptr_Typ, Loc),
- Expression =>
- Make_Reference (Loc,
- Prefix => Relocate_Node (Func_Call)));
+ Object_Definition => New_Reference_To (Ptr_Typ, Loc),
+ Expression => Make_Reference (Loc, Relocate_Node (Func_Call)));
Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
Rewrite (Assign, Make_Null_Statement (Loc));
Ptr_Typ_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ref_Type,
- Type_Definition =>
+ Type_Definition =>
Make_Access_To_Object_Definition (Loc,
- All_Present => True,
+ All_Present => True,
Subtype_Indication =>
New_Reference_To (Etype (Function_Call), Loc)));
-- Finally, create an access object initialized to a reference to the
-- function call.
- New_Expr :=
- Make_Reference (Loc,
- Prefix => Relocate_Node (Func_Call));
+ New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
Def_Id := Make_Temporary (Loc, 'R', New_Expr);
Set_Etype (Def_Id, Ref_Type);
-- Present for all build-in-place functions. Address at which to place
-- the return object, or null if BIP_Alloc_Form indicates allocated by
-- callee.
- -- ??? We also need to be able to pass in some way to access a
- -- user-defined storage pool at some point. And perhaps a constrained
- -- flag.
+ --
+ -- ??? We also need to be able to pass in some way to access a user-
+ -- defined storage pool at some point. And perhaps a constrained flag.
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String;
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
Adjust_Case => Name_Adjust,
Finalize_Case => Name_Finalize,
Address_Case => Name_Finalize_Address);
-
Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
(Initialize_Case => TSS_Deep_Initialize,
Adjust_Case => TSS_Deep_Adjust,
if VM_Target = No_VM then
Set_TSS (Typ,
- Make_Deep_Proc (
- Prim => Address_Case,
- Typ => Typ,
- Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
+ Make_Deep_Proc
+ (Prim => Address_Case,
+ Typ => Typ,
+ Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
end if;
end Build_Array_Deep_Procs;
and then Is_Task_Allocation_Block (N);
Is_Task_Body : constant Boolean :=
Nkind (Original_Node (N)) = N_Task_Body;
+
Loc : constant Source_Ptr := Sloc (N);
Stmts : constant List_Id := New_List;
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name => Nam,
+ Name => Nam,
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (
+ Prefix => New_Reference_To (
Defining_Identifier (Param), Loc),
Selector_Name =>
Make_Identifier (Loc, Name_uObject)),
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name => Nam,
+ Name => Nam,
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
New_Reference_To
(Defining_Identifier (Param), Loc),
Selector_Name =>
if Abort_Allowed then
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Abort_Undefer), Loc),
Parameter_Associations => Empty_List));
end if;
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (
- RTE (RE_Expunge_Unactivated_Tasks), Loc),
+ New_Reference_To
+ (RTE (RE_Expunge_Unactivated_Tasks), Loc),
Parameter_Associations => New_List (
New_Reference_To (Activation_Chain_Entity (N), Loc))));
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Enqueued), Loc),
Parameter_Associations => New_List (
New_Reference_To (Cancel_Param, Loc))),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Reference_To (
- RTE (RE_Cancel_Protected_Entry_Call), Loc),
+ New_Reference_To
+ (RTE (RE_Cancel_Protected_Entry_Call), Loc),
Parameter_Associations => New_List (
New_Reference_To (Cancel_Param, Loc))))));
elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Reference_To (Cancel_Param, Loc),
Attribute_Name => Name_Unchecked_Access))));
else
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Cancel_Task_Entry_Call), Loc),
Parameter_Associations => New_List (
New_Reference_To (Cancel_Param, Loc))));
begin
if Is_Array_Type (Typ) then
Build_Array_Deep_Procs (Typ);
-
else pragma Assert (Is_Record_Type (Typ));
Build_Record_Deep_Procs (Typ);
end if;
else
return
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Finalize_Protection), Loc),
- Parameter_Associations =>
- New_List (Concurrent_Ref (Ref)));
+ Parameter_Associations => New_List (Concurrent_Ref (Ref)));
end if;
end Cleanup_Protected_Object;
Ref : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
+
begin
-- For restricted run-time libraries (Ravenscar), tasks are
-- non-terminating and they can only appear at library level, so we do
else
return
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Free_Task), Loc),
- Parameter_Associations =>
- New_List (Concurrent_Ref (Ref)));
+ Parameter_Associations => New_List (Concurrent_Ref (Ref)));
end if;
end Cleanup_Task;
------------------------
function Enclosing_Function (E : Entity_Id) return Entity_Id is
- Func_Id : Entity_Id := E;
+ Func_Id : Entity_Id;
begin
+ Func_Id := E;
while Present (Func_Id)
and then Func_Id /= Standard_Standard
loop
-- appear.
procedure Expand_N_Package_Declaration (N : Node_Id) is
- Id : constant Entity_Id := Defining_Entity (N);
- Spec : constant Node_Id := Specification (N);
- Decls : List_Id;
- Fin_Id : Entity_Id;
+ Id : constant Entity_Id := Defining_Entity (N);
+ Spec : constant Node_Id := Specification (N);
+ Decls : List_Id;
+ Fin_Id : Entity_Id;
+
No_Body : Boolean := False;
- -- True in the case of a package declaration that is a compilation unit
- -- and for which no associated body will be compiled in
- -- this compilation.
+ -- True in the case of a package declaration that is a compilation
+ -- unit and for which no associated body will be compiled in this
+ -- compilation.
begin
-- Case of a package declaration other than a compilation unit
No_Body := True;
-- Special case of generating calling stubs for a remote call interface
- -- package: even though the package declaration requires one, the
- -- body won't be processed in this compilation (so any stubs for RACWs
- -- declared in the package must be generated here, along with the
- -- spec).
+ -- package: even though the package declaration requires one, the body
+ -- won't be processed in this compilation (so any stubs for RACWs
+ -- declared in the package must be generated here, along with the spec).
elsif Parent (N) = Cunit (Main_Unit)
and then Is_Remote_Call_Interface (Id)
Before : List_Id renames SE.Actions_To_Be_Wrapped_Before;
procedure Process_Transient_Objects
- (First_Object : Node_Id;
- Last_Object : Node_Id;
- Related_Node : Node_Id);
+ (First_Object : Node_Id;
+ Last_Object : Node_Id;
+ Related_Node : Node_Id);
-- First_Object and Last_Object define a list which contains potential
-- controlled transient objects. Finalization flags are inserted before
-- First_Object and finalization calls are inserted after Last_Object.
-------------------------------
procedure Process_Transient_Objects
- (First_Object : Node_Id;
- Last_Object : Node_Id;
- Related_Node : Node_Id)
+ (First_Object : Node_Id;
+ Last_Object : Node_Id;
+ Related_Node : Node_Id)
is
Abort_Id : Entity_Id;
Built : Boolean := False;
and then Analyzed (Stmt)
and then Is_Finalizable_Transient (Stmt, N)
- -- Do not process the node to be wrapped since it will be
- -- handled by the enclosing finalizer.
+ -- Do not process the node to be wrapped since it will be
+ -- handled by the enclosing finalizer.
and then Stmt /= Related_Node
then
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
- Make_Final_Call (
- Obj_Ref => Obj_Ref,
- Typ => Desig)),
+ Make_Final_Call
+ (Obj_Ref => Obj_Ref,
+ Typ => Desig)),
Exception_Handlers => New_List (
Build_Exception_Handler (Loc, E_Id, Raised_Id))));
-- Add all actions associated with a transient scope into the main
-- tree. There are several scenarios here:
- --
+
-- +--- Before ----+ +----- After ---+
-- 1) First_Obj ....... Target ........ Last_Obj
- --
+
-- 2) First_Obj ....... Target
- --
+
-- 3) Target ........ Last_Obj
if Present (Before) then
Ptr_Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Obj_Ref);
-
begin
return
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Attach), Loc),
Parameter_Associations => New_List (
New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
begin
return
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Detach), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
return
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Proc_Id, Loc),
+ Name => New_Reference_To (Proc_Id, Loc),
Parameter_Associations => Params);
end Make_Call;
Comp_Ref :=
Make_Indexed_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Expressions =>
- New_References_To (Index_List, Loc));
+ Prefix => Make_Identifier (Loc, Name_V),
+ Expressions => New_References_To (Index_List, Loc));
Set_Etype (Comp_Ref, Comp_Typ);
-- Generate:
-- [Deep_]Adjust (V (J1, ..., JN))
if Prim = Adjust_Case then
- Call :=
- Make_Adjust_Call (
- Obj_Ref => Comp_Ref,
- Typ => Comp_Typ);
+ Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
-- Generate:
-- [Deep_]Finalize (V (J1, ..., JN))
else pragma Assert (Prim = Finalize_Case);
- Call :=
- Make_Final_Call (
- Obj_Ref => Comp_Ref,
- Typ => Comp_Typ);
+ Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end if;
-- Generate the block which houses the adjust or finalize call:
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call),
-
- Exception_Handlers => New_List (
- Build_Exception_Handler (Loc, E_Id, Raised_Id))));
+ Statements => New_List (Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Loc, E_Id, Raised_Id))));
else
Core_Loop := Call;
end if;
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
+ Defining_Identifier => Loop_Id,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Attribute_Name =>
- Name_Range,
- Expressions => New_List (
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
Make_Integer_Literal (Loc, Dim))),
Reverse_Present => Prim = Finalize_Case)),
return
New_List (
Make_Block_Statement (Loc,
- Declarations =>
+ Declarations =>
Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts)));
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
end Build_Adjust_Or_Finalize_Statements;
---------------------------------
while Dim <= Num_Dims loop
Expr :=
Make_Op_Multiply (Loc,
- Left_Opnd =>
- Expr,
+ Left_Opnd => Expr,
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Attribute_Name =>
- Name_Length,
- Expressions => New_List (
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Length,
+ Expressions => New_List (
Make_Integer_Literal (Loc, Dim))));
Dim := Dim + 1;
return
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Counter_Id, Loc),
+ Name => New_Reference_To (Counter_Id, Loc),
Expression =>
Make_Op_Subtract (Loc,
- Left_Opnd =>
- Expr,
- Right_Opnd =>
- New_Reference_To (Counter_Id, Loc)));
+ Left_Opnd => Expr,
+ Right_Opnd => New_Reference_To (Counter_Id, Loc)));
end Build_Counter_Assignment;
-----------------------------
function Build_Finalization_Call return Node_Id is
Comp_Ref : constant Node_Id :=
Make_Indexed_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Expressions =>
- New_References_To (Final_List, Loc));
+ Prefix => Make_Identifier (Loc, Name_V),
+ Expressions => New_References_To (Final_List, Loc));
begin
Set_Etype (Comp_Ref, Comp_Typ);
-- Generate:
-- [Deep_]Finalize (V);
- return
- Make_Final_Call (
- Obj_Ref => Comp_Ref,
- Typ => Comp_Typ);
+ return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end Build_Finalization_Call;
-------------------
-- Generate:
-- [Deep_]Initialize (V (J1, ..., JN));
- return
- Make_Init_Call (
- Obj_Ref => Comp_Ref,
- Typ => Comp_Typ);
+ return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end Build_Initialization_Call;
-- Start of processing for Build_Initialize_Statements
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Build_Finalization_Call),
-
- Exception_Handlers => New_List (
- Build_Exception_Handler (Loc, E_Id, Raised_Id))));
+ Statements => New_List (Build_Finalization_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Loc, E_Id, Raised_Id))));
else
Fin_Stmt := Build_Finalization_Call;
end if;
Make_If_Statement (Loc,
Condition =>
Make_Op_Gt (Loc,
- Left_Opnd =>
- New_Reference_To (Counter_Id, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 0)),
+ Left_Opnd => New_Reference_To (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To (Counter_Id, Loc),
+ Name => New_Reference_To (Counter_Id, Loc),
Expression =>
Make_Op_Subtract (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)))),
Else_Statements => New_List (Fin_Stmt));
Defining_Identifier => Loop_Id,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Attribute_Name =>
- Name_Range,
- Expressions => New_List (
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
Make_Integer_Literal (Loc, Dim))),
Reverse_Present => True)),
Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
-- Generate the block which contains the initialization call and
-- the partial finalization code.
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
- Statements => New_List (
- Final_Block)))));
+ Statements => New_List (Final_Block)))));
Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
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))));
-- Generate all initialization loops starting from the innermost
-- dimension.
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
- Object_Definition =>
+ Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
- Expression =>
- Make_Integer_Literal (Loc, 0))),
+ Expression => Make_Integer_Literal (Loc, 0))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Init_Loop))));
+ Statements => New_List (Init_Loop))));
end Build_Initialize_Statements;
-----------------------
if Prim = Address_Case then
Formals := New_List (
Make_Parameter_Specification (Loc,
- Make_Defining_Identifier (Loc, Name_V),
- Parameter_Type =>
- New_Reference_To (RTE (RE_Address), Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)));
-- Default case
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 (Typ, Loc)));
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type => New_Reference_To (Typ, Loc)));
-- F : Boolean := True
then
Append_To (Formals,
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_F),
- Parameter_Type =>
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
+ Parameter_Type =>
New_Reference_To (Standard_Boolean, Loc),
- Expression =>
+ Expression =>
New_Reference_To (Standard_True, Loc)));
end if;
end if;
Declarations => Empty_List,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts)));
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
return Proc_Id;
end Make_Deep_Proc;
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_Copy_List (Discrete_Choices (Var)),
- Statements =>
+ Statements =>
Process_Component_List_For_Adjust (
Component_List (Var))));
Make_Case_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
+ Prefix => Make_Identifier (Loc, Name_V),
Selector_Name =>
Make_Identifier (Loc,
- Chars (Name (Variant_Part (Comps))))),
+ Chars => Chars (Name (Variant_Part (Comps))))),
Alternatives => Var_Alts);
end;
end if;
begin
if Needs_Finalization (Par_Typ) then
Call :=
- Make_Adjust_Call (
- Obj_Ref =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Selector_Name =>
- Make_Identifier (Loc, Name_uParent)),
- Typ => Par_Typ,
- For_Parent => True);
+ Make_Adjust_Call
+ (Obj_Ref =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uParent)),
+ Typ => Par_Typ,
+ For_Parent => True);
-- Generate:
-- Deep_Adjust (V._parent, False); -- No_Except_Propagat
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Adj_Stmt),
-
+ Statements => New_List (Adj_Stmt),
Exception_Handlers => New_List (
Build_Exception_Handler
(Loc, E_Id, Raised_Id))));
if Present (Proc) then
Adj_Stmt :=
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Proc, Loc),
+ Name => New_Reference_To (Proc, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_V)));
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Adj_Stmt),
-
+ Statements => New_List (Adj_Stmt),
Exception_Handlers => New_List (
Build_Exception_Handler
(Loc, E_Id, Raised_Id))));
Append_To (Bod_Stmts,
Make_If_Statement (Loc,
- Condition =>
- Make_Identifier (Loc, Name_F),
+ Condition => Make_Identifier (Loc, Name_F),
Then_Statements => New_List (Adj_Stmt)));
end if;
end;
return
New_List (
Make_Block_Statement (Loc,
- Declarations =>
+ Declarations =>
Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
-
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Bod_Stmts)));
+ Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
end if;
end Build_Adjust_Statements;
Append_To (Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Label_Id),
- Label_Construct => Label));
+ Label_Construct => Label));
-- Generate:
-- when N =>
-- end;
Fin_Stmt :=
- Make_Final_Call (
- Obj_Ref =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Id))),
- Typ => Typ);
+ Make_Final_Call
+ (Obj_Ref =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name => Make_Identifier (Loc, Chars (Id))),
+ Typ => Typ);
if not Restriction_Active (No_Exception_Propagation) then
Fin_Stmt :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Fin_Stmt),
-
+ Statements => New_List (Fin_Stmt),
Exception_Handlers => New_List (
Build_Exception_Handler (Loc, E_Id, Raised_Id))));
end if;
Jump_Block :=
Make_Block_Statement (Loc,
- Declarations => Decls,
+ Declarations => Decls,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
+ Make_Handled_Sequence_Of_Statements (Loc, Stmts));
if Present (Var_Case) then
return New_List (Var_Case, Jump_Block);
begin
if Needs_Finalization (Par_Typ) then
Call :=
- Make_Final_Call (
- Obj_Ref =>
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Name_V),
- Selector_Name =>
- Make_Identifier (Loc, Name_uParent)),
- Typ => Par_Typ,
- For_Parent => True);
+ Make_Final_Call
+ (Obj_Ref =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uParent)),
+ Typ => Par_Typ,
+ For_Parent => True);
-- Generate:
-- Deep_Finalize (V._parent, False); -- No_Except_Propag
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Fin_Stmt),
-
+ Statements => New_List (Fin_Stmt),
Exception_Handlers => New_List (
Build_Exception_Handler
(Loc, E_Id, Raised_Id))));
if Present (Proc) then
Fin_Stmt :=
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (Proc, Loc),
+ Name => New_Reference_To (Proc, Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_V)));
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Fin_Stmt),
-
+ Statements => New_List (Fin_Stmt),
Exception_Handlers => New_List (
Build_Exception_Handler
(Loc, E_Id, Raised_Id))));
Prepend_To (Bod_Stmts,
Make_If_Statement (Loc,
- Condition =>
- Make_Identifier (Loc, Name_F),
+ Condition => Make_Identifier (Loc, Name_F),
Then_Statements => New_List (Fin_Stmt)));
end if;
end;
return
New_List (
Make_Block_Statement (Loc,
- Declarations =>
+ Declarations =>
Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
-
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Bod_Stmts)));
+ Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
end if;
end Build_Finalize_Statements;
if Is_Controlled (Typ) then
return New_List (
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (
- Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
-
+ Name =>
+ New_Reference_To
+ (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc, Name_V))));
else
elsif Is_Class_Wide_Type (Typ)
and then Has_Discriminants (Root_Type (Typ))
- and then not Is_Empty_Elmt_List (
- Discriminant_Constraint (Root_Type (Typ)))
+ and then not
+ Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
then
declare
Parent_Typ : Entity_Id := Root_Type (Typ);
while Parent_Typ /= Etype (Parent_Typ)
and then Has_Discriminants (Parent_Typ)
- and then not Is_Empty_Elmt_List (
- Discriminant_Constraint (Parent_Typ))
+ and then not
+ Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
loop
Parent_Typ := Etype (Parent_Typ);
end loop;
New_Reference_To (Desg_Typ, Loc))),
Make_Attribute_Definition_Clause (Loc,
- Name =>
- New_Reference_To (Ptr_Typ, Loc),
- Chars => Name_Storage_Size,
- Expression =>
- Make_Integer_Literal (Loc, 0)));
+ Name => New_Reference_To (Ptr_Typ, Loc),
+ Chars => Name_Storage_Size,
+ Expression => Make_Integer_Literal (Loc, 0)));
Obj_Expr := Make_Identifier (Loc, Name_V);
begin
return
Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc, 2),
+ Left_Opnd => Make_Integer_Literal (Loc, 2),
Right_Opnd =>
Make_Op_Divide (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Integer_Literal (Loc, Esize (Typ)),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit)));
Append_To (Decls,
Make_Attribute_Definition_Clause (Loc,
- Name =>
- New_Reference_To (Ptr_Typ, Loc),
- Chars => Name_Size,
+ Name => New_Reference_To (Ptr_Typ, Loc),
+ Chars => Name_Size,
Expression =>
Make_Integer_Literal (Loc, System_Address_Size)));
else
Dope_Expr :=
Make_Op_Add (Loc,
- Left_Opnd =>
- Dope_Expr,
- Right_Opnd =>
- Bounds_Size_Expression (Etype (Index)));
+ Left_Opnd => Dope_Expr,
+ Right_Opnd => Bounds_Size_Expression (Etype (Index)));
end if;
Next_Index (Index);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Dope_Id,
- Constant_Present => True,
- Object_Definition =>
+ Constant_Present => True,
+ Object_Definition =>
New_Reference_To (RTE (RE_Storage_Offset), Loc),
- Expression => Dope_Expr));
+ Expression => Dope_Expr));
-- Shift the address from the start of the dope vector to the
-- start of the elements:
Obj_Expr :=
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Add_Offset_To_Address), Loc),
Parameter_Associations => New_List (
Obj_Expr,
Make_Final_Call (
Obj_Ref =>
Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
+ Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
Typ => Desg_Typ)))));
end Make_Finalize_Address_Stmts;
E_Occ := Make_Defining_Identifier (Loc, Name_E);
Raise_Node :=
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Reraise_Occurrence), Loc),
Parameter_Associations => New_List (
New_Reference_To (E_Occ, Loc)));
E_Occ := Make_Defining_Identifier (Loc, Name_E);
Raise_Node :=
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To
(RTE (RE_Raise_From_Controlled_Operation), Loc),
Parameter_Associations => New_List (
if Has_Controlled_Component (Utyp) then
Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
-
else
Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
-- V : in out Typ
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_V),
- In_Present => True,
- Out_Present => True,
- Parameter_Type =>
- New_Reference_To (Typ, Loc)),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type => New_Reference_To (Typ, Loc)),
-- F : Boolean := True
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)));
-- Add the necessary number of counters to represent the initialization
-- state of an object.
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Nam,
+ Defining_Unit_Name => Nam,
Parameter_Specifications => Formals),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- Make_Deep_Record_Body (Finalize_Case, Typ, True)));
+ Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
end Make_Local_Deep_Finalize;
----------------------------------------
return
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Set_Finalize_Address_Ptr), Loc),
Parameter_Associations => New_List (
New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
Attribute_Name => Name_Unrestricted_Access)));
end Make_Set_Finalize_Address_Ptr_Call;
Block :=
Make_Block_Statement (Loc,
- Identifier =>
- New_Reference_To (Current_Scope, Loc),
- Declarations => Decls,
+ Identifier => New_Reference_To (Current_Scope, Loc),
+ Declarations => Decls,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Instrs),
- Has_Created_Identifier => True);
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
+ Has_Created_Identifier => True);
Set_Parent (Block, Par);
-- Insert actions stuck in the transient scopes as well as all freezing
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_Definition =>
- New_Reference_To (Typ, Loc)),
+ Object_Definition => New_Reference_To (Typ, Loc)),
Make_Transient_Block (Loc,
Action =>
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Temp, Loc),
Expression => Expr),
- Par => Parent (N))));
+ Par => Parent (N))));
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, Typ);
-- Create a call to prepend an object to a finalization collection. Obj_Ref
-- is the object, Ptr_Typ is the access type that owns the collection.
-- Generate the following:
-
+ --
-- Ada.Finalization.Heap_Managment.Attach
-- (<Ptr_Typ>FC,
-- System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id;
-- Create a call to unhook an object from an arbitrary list. Obj_Ref is the
-- object. Generate the following:
-
+ --
-- Ada.Finalization.Heap_Management.Detach
-- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
Make_Component_Association (Loc,
Choices => New_List (Make_Identifier (Loc, Name_Ras)),
Expression =>
- PolyORB_Support.Helpers.Build_From_Any_Call (
- Underlying_RACW_Type (RAS_Type),
- New_Occurrence_Of (Any_Parameter, Loc),
- No_List))))));
+ PolyORB_Support.Helpers.Build_From_Any_Call
+ (Underlying_RACW_Type (RAS_Type),
+ New_Occurrence_Of (Any_Parameter, Loc),
+ No_List))))));
Func_Spec :=
Make_Function_Specification (Loc,
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_TA_I32), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_TA_I32), Loc),
Parameter_Associations => New_List (Expr_Node)));
end Add_Long_Parameter;
Odecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
- Object_Definition =>
+ Object_Definition =>
New_Occurrence_Of (Stream_Base_Type (Typ), Loc));
else
Odecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
- Object_Definition =>
+ Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Ranges)));
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, Ranges)));
end if;
- Rstmt := Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- Make_Identifier (Loc, Name_S),
- Make_Identifier (Loc, Name_V)));
+ Rstmt :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Make_Identifier (Loc, Name_V)));
if Ada_Version >= Ada_2005 then
Stms := New_List (
Make_Extended_Return_Statement (Loc,
Return_Object_Declarations => New_List (Odecl),
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- New_List (Rstmt))));
+ Make_Handled_Sequence_Of_Statements (Loc, New_List (Rstmt))));
else
-- pragma Assert (not Is_Limited_Type (Typ));
-- Returning a local object, shouldn't happen in the case of a
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Read,
- Expressions => New_List (
+ Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V)))))));
else
-----------------
function Find_Object (E : Node_Id) return Node_Id is
- Expr : Node_Id := E;
- Change : Boolean := True;
+ Expr : Node_Id;
begin
pragma Assert (Is_Allocate);
- while Change loop
- Change := False;
-
+ Expr := E;
+ loop
if Nkind_In (Expr, N_Qualified_Expression,
N_Unchecked_Type_Conversion)
then
- Expr := Expression (Expr);
- Change := True;
+ Expr := Expression (Expr);
elsif Nkind (Expr) = N_Explicit_Dereference then
- Expr := Prefix (Expr);
- Change := True;
+ Expr := Prefix (Expr);
+
+ else
+ exit;
end if;
end loop;
function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
Expr : constant Node_Id := Related_Expression (Id);
-
begin
return
Present (Expr)
-- Return the stream size value of the subtype E
function Has_Access_Constraint (E : Entity_Id) return Boolean;
- -- Given object or type E, determine whether a discriminant is of an access
- -- type.
+ -- Given object or type E, determine if a discriminant is of an access type
function Has_Controlled_Objects (N : Node_Id) return Boolean;
- -- Given an arbitrary node N, determine whether it has a declarative or a
- -- statement part and whether those lists contain at least one controlled
- -- object.
+ -- Given a node N, determine if it has a declarative or a statement part
+ -- and whether those lists contain at least one controlled object.
function Has_Controlled_Objects
(L : List_Id;
Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
return True;
+
else
return False;
end if;
if Has_Foreign_Convention (E)
- -- We are looking for a return of unconstrained array
+ -- We are looking for a return of unconstrained array
and then Is_Array_Type (R_Type)
and then not Is_Constrained (R_Type)
- -- Exclude imported routines, the warning does not
- -- belong on the import, but rather on the routine
- -- definition.
+ -- Exclude imported routines, the warning does not
+ -- belong on the import, but rather on the routine
+ -- definition.
and then not Is_Imported (E)
- -- Exclude VM case, since both .NET and JVM can handle
- -- return of unconstrained arrays without a problem.
+ -- Exclude VM case, since both .NET and JVM can handle
+ -- return of unconstrained arrays without a problem.
and then VM_Target = No_VM
- -- Check that general warning is enabled, and that it
- -- is not suppressed for this particular case.
+ -- Check that general warning is enabled, and that it
+ -- is not suppressed for this particular case.
and then Warn_On_Export_Import
and then not Has_Warnings_Off (E)
if Is_Pure_Unit_Access_Type (E)
and then (Ada_Version < Ada_2005
- or else not No_Pool_Assigned (E))
+ or else not No_Pool_Assigned (E))
then
Error_Msg_N ("named access type not allowed in pure unit", E);
elsif Is_Array_Type (Retype)
and then not Is_Constrained (Retype)
- -- Exclude cases where descriptor mechanism is set, since the
- -- VMS descriptor mechanisms allow such unconstrained returns.
+ -- Exclude cases where descriptor mechanism is set, since the
+ -- VMS descriptor mechanisms allow such unconstrained returns.
and then Mechanism (E) not in Descriptor_Codes
and then Warn_On_Export_Import
- -- Exclude the VM case, since return of unconstrained arrays
- -- is properly handled in both the JVM and .NET cases.
+ -- Exclude the VM case, since return of unconstrained arrays
+ -- is properly handled in both the JVM and .NET cases.
and then VM_Target = No_VM
then
Declarations => New_List (
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'T'),
- Object_Definition =>
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Object_Definition =>
New_Occurrence_Of (Etype (Formal), Loc),
- Expression => New_Copy_Tree (Dcopy))),
+ Expression => New_Copy_Tree (Dcopy))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List));
+ Statements => Empty_List));
Set_Scope (Dnam, Scope (E));
Set_Assignment_OK (First (Declarations (Dbody)));
(Config : Command_Line_Configuration;
Section : String);
-- Iterate over all switches defined in Config, for a specific section.
- -- Index is set to the index in Config.Switches.
- -- Stop iterating when Callback returns False.
+ -- Index is set to the index in Config.Switches. Stop iterating when
+ -- Callback returns False.
--------------
-- Argument --
loop
begin
if Cmd.Config /= null then
+
-- Do not use Getopt_Description in this case. Otherwise,
-- if we have defined a prefix -gnaty, and two switches
-- -gnatya and -gnatyL!, we would have a different behavior
-- depending on the order of switches:
+
-- -gnatyL1a => -gnatyL with argument "1a"
-- -gnatyaL1 => -gnatya and -gnatyL with argument "1"
+
-- This is because the call to Getopt below knows nothing
-- about prefixes, and in the first case finds a valid
-- switch with arguments, so returns it without analyzing
S := Getopt (Switches => "*",
Concatenate => False,
Parser => Parser);
+
else
S := Getopt (Switches => "* " & Getopt_Description,
Concatenate => False,
exit when S = ASCII.NUL;
declare
- Sw : constant String :=
- Real_Full_Switch (S, Parser);
- Is_Section : Boolean := False;
+ Sw : constant String := Real_Full_Switch (S, Parser);
+ Is_Section : Boolean := False;
begin
if Cmd.Config /= null
is
pragma Unreferenced (Index);
- Full : constant String := Prefix & Group (Idx .. Group'Last);
+ Full : constant String := Prefix & Group (Idx .. Group'Last);
- Sw : constant String := Actual_Switch (Switch);
+ Sw : constant String := Actual_Switch (Switch);
-- Switches definition minus argument definition
Last : Natural;
Param : Natural;
begin
- if
- -- Verify that sw starts with Prefix
- Looking_At (Sw, Sw'First, Prefix)
+ -- Verify that sw starts with Prefix
- -- Verify that the group starts with sw
- and then Looking_At (Full, Full'First, Sw)
+ if Looking_At (Sw, Sw'First, Prefix)
+
+ -- Verify that the group starts with sw
+ and then Looking_At (Full, Full'First, Sw)
then
Last := Idx + Sw'Length - Prefix'Length - 1;
Param := Last + 1;
if Can_Have_Parameter (Switch) then
- -- Include potential parameter to the recursive call.
- -- Only numbers are allowed.
+
+ -- Include potential parameter to the recursive call. Only
+ -- numbers are allowed.
while Last < Group'Last
and then Group (Last + 1) in '0' .. '9'
return False;
end if;
end if;
+
return True;
end Analyze_Simple_Switch;
-- results with or without this call.
Foreach_In_Config (Config, Section);
+
if Found_In_Config then
return;
end if;
if Config /= null and then Config.Prefixes /= null then
for P in Config.Prefixes'Range loop
if Switch'Length > Config.Prefixes (P)'Length + 1
- and then Looking_At
- (Switch, Switch'First, Config.Prefixes (P).all)
+ and then
+ Looking_At (Switch, Switch'First, Config.Prefixes (P).all)
then
-- Alias expansion will be done recursively
then
-- Recursive calls already done on each switch of the group:
-- Return without executing Callback.
+
return;
end if;
end if;
then
Found_In_Config := False;
Foreach_Starts_With (Config, Section);
+
if Found_In_Config then
return;
end if;
-- assumed that the remainder of the switch ("uv") is a set of characters
-- whose order is irrelevant. In fact, this package will sort them
-- alphabetically.
+ --
-- When grouping switches that accept arguments (for instance "-gnatyL!"
-- as the definition, and "-gnatyaL12b" as the command line), only
-- numerical arguments are accepted. The above is equivalent to
Config : Command_Line_Configuration);
function Get_Configuration
(Cmd : Command_Line) return Command_Line_Configuration;
- -- Set or retrieve the configuration used for that command line.
- -- The Config must have been initialized first, by calling one of the
- -- Define_Switches subprograms.
+ -- Set or retrieve the configuration used for that command line. The Config
+ -- must have been initialized first, by calling one of the Define_Switches
+ -- subprograms.
procedure Set_Command_Line
(Cmd : in out Command_Line;
--
-- The parsing of Switches is done through calls to Getopt, by passing
-- Getopt_Description as an argument. (A "*" is automatically prepended so
- -- that all switches and command line arguments are accepted).
- -- If a config was defined via Set_Configuration, the Getopt_Description
- -- parameter will be ignored.
+ -- that all switches and command line arguments are accepted). If a config
+ -- was defined via Set_Configuration, the Getopt_Description parameter will
+ -- be ignored.
--
-- To properly handle switches that take parameters, you should document
-- them in Getopt_Description. Otherwise, the switch and its parameter will
begin
Makeutl.Test_If_Relative_Path
(Switch, Parent,
- Do_Fail => Osint.Fail'Access,
- Including_Non_Switch => False, Including_RTS => True);
+ Do_Fail => Osint.Fail'Access,
+ Including_Non_Switch => False,
+ Including_RTS => True);
end Test_If_Relative_Path;
-------------------
-- Filter table Xrefs to add all references used in ALFA to the table
-- ALFA_Xref_Table.
+ procedure Detect_And_Add_ALFA_Scope (N : Node_Id);
+ -- Call Add_ALFA_Scope on scopes
+
function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
-- Hash function for hash table
- procedure Traverse_Declarations_Or_Statements (L : List_Id);
- procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
- procedure Traverse_Package_Body (N : Node_Id);
- procedure Traverse_Package_Declaration (N : Node_Id);
- procedure Traverse_Subprogram_Body (N : Node_Id);
- -- Traverse the corresponding construct, generating ALFA scope table
- -- entries.
+ procedure Traverse_Compilation_Unit
+ (CU : Node_Id;
+ Process : Node_Processing);
+ procedure Traverse_Declarations_Or_Statements
+ (L : List_Id;
+ Process : Node_Processing);
+ procedure Traverse_Handled_Statement_Sequence
+ (N : Node_Id;
+ Process : Node_Processing);
+ procedure Traverse_Package_Body
+ (N : Node_Id;
+ Process : Node_Processing);
+ procedure Traverse_Package_Declaration
+ (N : Node_Id;
+ Process : Node_Processing);
+ procedure Traverse_Subprogram_Body
+ (N : Node_Id;
+ Process : Node_Processing);
+ -- Traverse the corresponding constructs, calling Process on all
+ -- declarations.
-------------------
-- Add_ALFA_File --
-------------------
procedure Add_ALFA_File (U : Unit_Number_Type; D : Nat) is
- Lu : Node_Id;
From : Scope_Index;
S : constant Source_File_Index := Source_Index (U);
From := ALFA_Scope_Table.Last + 1;
- -- Get Unit (checking case of subunit)
-
- Lu := Unit (Cunit (U));
-
- if Nkind (Lu) = N_Subunit then
- Lu := Proper_Body (Lu);
- end if;
-
- -- Traverse the unit
-
- if Nkind (Lu) = N_Subprogram_Body then
- Traverse_Subprogram_Body (Lu);
-
- elsif Nkind (Lu) = N_Subprogram_Declaration then
- Add_ALFA_Scope (Lu);
-
- elsif Nkind (Lu) = N_Package_Declaration then
- Traverse_Package_Declaration (Lu);
-
- elsif Nkind (Lu) = N_Package_Body then
- Traverse_Package_Body (Lu);
-
- -- ??? TBD
-
- elsif Nkind (Lu) = N_Generic_Package_Declaration then
- null;
-
- -- ??? TBD
-
- elsif Nkind (Lu) in N_Generic_Instantiation then
- null;
-
- -- All other cases of compilation units (e.g. renamings), generate
- -- no ALFA information.
-
- else
- null;
- end if;
+ Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_ALFA_Scope'Access);
-- Update scope numbers
Add_ALFA_Xrefs;
end Collect_ALFA;
+ -------------------------------
+ -- Detect_And_Add_ALFA_Scope --
+ -------------------------------
+
+ procedure Detect_And_Add_ALFA_Scope (N : Node_Id) is
+ begin
+ if Nkind_In (N, N_Subprogram_Declaration,
+ N_Subprogram_Body,
+ N_Package_Declaration,
+ N_Package_Body)
+ then
+ Add_ALFA_Scope (N);
+ end if;
+ end Detect_And_Add_ALFA_Scope;
+
-----------------
-- Entity_Hash --
-----------------
Entity_Hashed_Range (E mod (Entity_Id (Entity_Hashed_Range'Last) + 1));
end Entity_Hash;
+ ------------------------------------
+ -- Traverse_All_Compilation_Units --
+ ------------------------------------
+
+ procedure Traverse_All_Compilation_Units (Process : Node_Processing) is
+ begin
+ for U in Units.First .. Last_Unit loop
+ Traverse_Compilation_Unit (Cunit (U), Process);
+ end loop;
+ end Traverse_All_Compilation_Units;
+
+ -------------------------------
+ -- Traverse_Compilation_Unit --
+ -------------------------------
+
+ procedure Traverse_Compilation_Unit
+ (CU : Node_Id;
+ Process : Node_Processing)
+ is
+ Lu : Node_Id;
+
+ begin
+ -- Get Unit (checking case of subunit)
+
+ Lu := Unit (CU);
+
+ if Nkind (Lu) = N_Subunit then
+ Lu := Proper_Body (Lu);
+ end if;
+
+ -- Call Process on all declarations
+
+ if Nkind (Lu) in N_Declaration
+ or else Nkind (Lu) in N_Later_Decl_Item
+ then
+ Process (Lu);
+ end if;
+
+ -- Traverse the unit
+
+ if Nkind (Lu) = N_Subprogram_Body then
+ Traverse_Subprogram_Body (Lu, Process);
+
+ elsif Nkind (Lu) = N_Subprogram_Declaration then
+ null;
+
+ elsif Nkind (Lu) = N_Package_Declaration then
+ Traverse_Package_Declaration (Lu, Process);
+
+ elsif Nkind (Lu) = N_Package_Body then
+ Traverse_Package_Body (Lu, Process);
+
+ -- ??? TBD
+
+ elsif Nkind (Lu) = N_Generic_Package_Declaration then
+ null;
+
+ -- ??? TBD
+
+ elsif Nkind (Lu) in N_Generic_Instantiation then
+ null;
+
+ -- All other cases of compilation units (e.g. renamings), are not
+ -- declarations.
+
+ else
+ null;
+ end if;
+ end Traverse_Compilation_Unit;
+
-----------------------------------------
-- Traverse_Declarations_Or_Statements --
-----------------------------------------
- procedure Traverse_Declarations_Or_Statements (L : List_Id) is
+ procedure Traverse_Declarations_Or_Statements
+ (L : List_Id;
+ Process : Node_Processing)
+ is
N : Node_Id;
begin
N := First (L);
while Present (N) loop
+ -- Call Process on all declarations
+
+ if Nkind (N) in N_Declaration
+ or else
+ Nkind (N) in N_Later_Decl_Item
+ then
+ Process (N);
+ end if;
+
case Nkind (N) is
-- Package declaration
when N_Package_Declaration =>
- Traverse_Package_Declaration (N);
+ Traverse_Package_Declaration (N, Process);
-- Generic package declaration ??? TBD
when N_Package_Body =>
if Ekind (Defining_Entity (N)) /= E_Generic_Package then
- Traverse_Package_Body (N);
+ Traverse_Package_Body (N, Process);
end if;
-- Subprogram declaration
when N_Subprogram_Declaration =>
- Add_ALFA_Scope (N);
+ null;
-- Generic subprogram declaration ??? TBD
when N_Subprogram_Body =>
if not Is_Generic_Subprogram (Defining_Entity (N)) then
- Traverse_Subprogram_Body (N);
+ Traverse_Subprogram_Body (N, Process);
end if;
-- Block statement
when N_Block_Statement =>
- Traverse_Declarations_Or_Statements (Declarations (N));
+ Traverse_Declarations_Or_Statements (Declarations (N), Process);
Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N));
+ (Handled_Statement_Sequence (N), Process);
when N_If_Statement =>
-- Traverse the statements in the THEN part
- Traverse_Declarations_Or_Statements (Then_Statements (N));
+ Traverse_Declarations_Or_Statements
+ (Then_Statements (N), Process);
-- Loop through ELSIF parts if present
begin
while Present (Elif) loop
Traverse_Declarations_Or_Statements
- (Then_Statements (Elif));
+ (Then_Statements (Elif), Process);
Next (Elif);
end loop;
end;
-- Finally traverse the ELSE statements if present
- Traverse_Declarations_Or_Statements (Else_Statements (N));
+ Traverse_Declarations_Or_Statements
+ (Else_Statements (N), Process);
-- Case statement
begin
Alt := First (Alternatives (N));
while Present (Alt) loop
- Traverse_Declarations_Or_Statements (Statements (Alt));
+ Traverse_Declarations_Or_Statements
+ (Statements (Alt), Process);
Next (Alt);
end loop;
end;
when N_Extended_Return_Statement =>
Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N));
+ (Handled_Statement_Sequence (N), Process);
-- Loop
when N_Loop_Statement =>
- Traverse_Declarations_Or_Statements (Statements (N));
+ Traverse_Declarations_Or_Statements (Statements (N), Process);
when others =>
null;
-- Traverse_Handled_Statement_Sequence --
-----------------------------------------
- procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
+ procedure Traverse_Handled_Statement_Sequence
+ (N : Node_Id;
+ Process : Node_Processing)
+ is
Handler : Node_Id;
begin
if Present (N) then
- Traverse_Declarations_Or_Statements (Statements (N));
+ Traverse_Declarations_Or_Statements (Statements (N), Process);
if Present (Exception_Handlers (N)) then
Handler := First (Exception_Handlers (N));
while Present (Handler) loop
- Traverse_Declarations_Or_Statements (Statements (Handler));
+ Traverse_Declarations_Or_Statements
+ (Statements (Handler), Process);
Next (Handler);
end loop;
end if;
-- Traverse_Package_Body --
---------------------------
- procedure Traverse_Package_Body (N : Node_Id) is
+ procedure Traverse_Package_Body
+ (N : Node_Id;
+ Process : Node_Processing) is
begin
- Add_ALFA_Scope (N);
- Traverse_Declarations_Or_Statements (Declarations (N));
- Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
+ Traverse_Declarations_Or_Statements (Declarations (N), Process);
+ Traverse_Handled_Statement_Sequence
+ (Handled_Statement_Sequence (N), Process);
end Traverse_Package_Body;
----------------------------------
-- Traverse_Package_Declaration --
----------------------------------
- procedure Traverse_Package_Declaration (N : Node_Id) is
+ procedure Traverse_Package_Declaration
+ (N : Node_Id;
+ Process : Node_Processing)
+ is
Spec : constant Node_Id := Specification (N);
begin
- Add_ALFA_Scope (N);
- Traverse_Declarations_Or_Statements (Visible_Declarations (Spec));
- Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
+ Traverse_Declarations_Or_Statements
+ (Visible_Declarations (Spec), Process);
+ Traverse_Declarations_Or_Statements
+ (Private_Declarations (Spec), Process);
end Traverse_Package_Declaration;
------------------------------
-- Traverse_Subprogram_Body --
------------------------------
- procedure Traverse_Subprogram_Body (N : Node_Id) is
+ procedure Traverse_Subprogram_Body
+ (N : Node_Id;
+ Process : Node_Processing) is
begin
- Add_ALFA_Scope (N);
- Traverse_Declarations_Or_Statements (Declarations (N));
- Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
+ Traverse_Declarations_Or_Statements (Declarations (N), Process);
+ Traverse_Handled_Statement_Sequence
+ (Handled_Statement_Sequence (N), Process);
end Traverse_Subprogram_Body;
end ALFA;
package ALFA is
+ type Node_Processing is access procedure (N : Node_Id);
+
+ procedure Traverse_All_Compilation_Units (Process : Node_Processing);
+ -- Call Process on all declarations through all compilation units
+
procedure Collect_ALFA (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat);
-- Collect ALFA information from library units (for files and scopes)
-- and from cross-references. Fill in the tables in library package
procedure Make_Failed (S : String);
-- Delete all temp files created by Gnatmake and call Osint.Fail, with the
-- parameter S (see osint.ads). This is called from the Prj hierarchy and
- -- the MLib hierarchy.
- -- This subprogram also prints current error messages on stdout (ie
- -- finalizes errout)
+ -- the MLib hierarchy. This subprogram also prints current error messages
+ -- on stdout (ie finalizes errout)
--------------------------
-- Obsolete Executables --
-- compiled, or has already been compiled for another executable.
Max_Header : constant := 200;
- -- This needs a proper comment, it used to say "arbitrary"
- -- that's not an adequate comment ???
+ -- This needs a proper comment, it used to say "arbitrary" that's not an
+ -- adequate comment ???
type Header_Num is range 1 .. Max_Header;
-- Header_Num for the hash table Obsoleted below
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Deallocation;
with ALI; use ALI;
with Debug;
with Err_Vars; use Err_Vars;
with Table;
with Tempdir;
-with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Unchecked_Deallocation;
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.Case_Util; use GNAT.Case_Util;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable;
-with GNAT.Regexp; use GNAT.Regexp;
+with GNAT.Regexp; use GNAT.Regexp;
package body Makeutl is
function Is_Subunit (Source : Prj.Source_Id) return Boolean is
Src_Ind : Source_File_Index;
+
begin
if Source.Kind = Sep then
return True;
-- A Spec, a file based language source or a body with a spec cannot be
-- a subunit.
- elsif Source.Kind = Spec or else
- Source.Unit = No_Unit_Index or else
- Other_Part (Source) /= No_Source
+ elsif Source.Kind = Spec
+ or else Source.Unit = No_Unit_Index
+ or else Other_Part (Source) /= No_Source
then
return False;
end if;
end if;
end Add_Main;
- --------------------------
- -- Set_Multi_Unit_Index --
- --------------------------
-
- procedure Set_Multi_Unit_Index
- (Project_Tree : Project_Tree_Ref := null;
- Index : Int := 0) is
- begin
- if Index /= 0 then
- if Names.Last = 0 then
- Fail_Program
- (Project_Tree,
- "cannot specify a multi-unit index but no main " &
- "on the command line");
-
- elsif Names.Last > 1 then
- Fail_Program
- (Project_Tree,
- "cannot specify several mains with a multi-unit index");
-
- else
- Names.Table (Names.Last).Index := Index;
- end if;
- end if;
- end Set_Multi_Unit_Index;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete is
- begin
- Names.Set_Last (0);
- Mains.Reset;
- end Delete;
-
--------------------
-- Complete_Mains --
--------------------
end if;
end Do_Complete;
+ -- Start of processing for Complete_Mains
+
begin
Complete_All (Root_Project, Project_Tree);
end Complete_Mains;
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete is
+ begin
+ Names.Set_Last (0);
+ Mains.Reset;
+ end Delete;
+
-----------------------
- -- FIll_From_Project --
+ -- Fill_From_Project --
-----------------------
procedure Fill_From_Project
-- Add the main units from this project into Mains.
-- This takes into account the aggregated projects
+ ----------------------------
+ -- Add_Mains_From_Project --
+ ----------------------------
+
procedure Add_Mains_From_Project
(Project : Project_Id;
Tree : Project_Tree_Ref)
procedure Fill_All is new For_Project_And_Aggregated
(Add_Mains_From_Project);
+ -- Start of processing for Fill_From_Project
+
begin
Fill_All (Root_Project, Project_Tree);
end Fill_From_Project;
---------------
function Next_Main return String is
- Info : Main_Info;
+ Info : constant Main_Info := Next_Main;
begin
- Info := Next_Main;
if Info = No_Main_Info then
return "";
else
end if;
end Next_Main;
- ---------------
- -- Next_Main --
- ---------------
-
function Next_Main return Main_Info is
begin
if Current >= Names.Last then
begin
Current := 0;
end Reset;
+
+ --------------------------
+ -- Set_Multi_Unit_Index --
+ --------------------------
+
+ procedure Set_Multi_Unit_Index
+ (Project_Tree : Project_Tree_Ref := null;
+ Index : Int := 0)
+ is
+ begin
+ if Index /= 0 then
+ if Names.Last = 0 then
+ Fail_Program
+ (Project_Tree,
+ "cannot specify a multi-unit index but no main " &
+ "on the command line");
+
+ elsif Names.Last > 1 then
+ Fail_Program
+ (Project_Tree,
+ "cannot specify several mains with a multi-unit index");
+
+ else
+ Names.Table (Names.Last).Index := Index;
+ end if;
+ end if;
+ end Set_Multi_Unit_Index;
+
end Mains;
-----------------------
return;
end if;
- -- Because relative path arguments to --RTS= may be relative
- -- to the search directory prefix, those relative path
- -- arguments are converted only when they include directory
- -- information.
+ -- Because relative path arguments to --RTS= may be relative to
+ -- the search directory prefix, those relative path arguments
+ -- are converted only when they include directory information.
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
if Parent'Length = 0 then
Write_Eol;
end Verbose_Msg;
- -----------------
- -- Verbose_Msg --
- -----------------
-
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
-----------
package body Queue is
+
type Q_Record is record
Info : Source_Info;
Processed : Boolean;
with Namet; use Namet;
with Opt;
with Osint;
-with Prj; use Prj;
+with Prj; use Prj;
with Prj.Tree;
with Types; use Types;
package Makeutl is
type Fail_Proc is access procedure (S : String);
+ -- Pointer to procedure which outputs a failure message
On_Windows : constant Boolean := Directory_Separator = '\';
-- True when on Windows
-- Return True if source is a subunit
procedure Initialize_Source_Record (Source : Source_Id);
- -- Get information either about the source file, the object and
- -- dependency file, as well as their timestamps. This includes timestamps.
+ -- Get information either about the source file, or the object and
+ -- dependency file, as well as their timestamps.
function Is_External_Assignment
(Env : Prj.Tree.Environment;
Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
S : String := "");
-- Terminate program, with or without a message, setting the status code
- -- according to Fatal.
- -- This properly removes all temporary files
+ -- according to Fatal. This properly removes all temporary files.
-----------------------
-- Project_Tree data --
-----------------------
+
-- The following types are specific to builders, and associated with each
-- of the loaded project trees.
Option_Compile_Only : Boolean := False; -- Was "-c" specified ?
Option_Bind_Only : Boolean := False;
Option_Link_Only : Boolean := False);
- -- Compute which compilation phases will be needed for Tree. This also
- -- does the computation for aggregated trees.
- -- This also check whether we'll need to check the closure of the files we
- -- have just compiled to add them to the queue.
+ -- Compute which compilation phases will be needed for Tree. This also does
+ -- the computation for aggregated trees. This also check whether we'll need
+ -- to check the closure of the files we have just compiled to add them to
+ -- the queue.
-----------
-- Mains --
Project : Project_Id;
Tree : Project_Tree_Ref;
end record;
+
No_Main_Info : constant Main_Info :=
- (No_File, 0, No_Location, No_Source, No_Project, null);
+ (No_File, 0, No_Location, No_Source, No_Project, null);
package Mains is
procedure Add_Main
Location : Source_Ptr := No_Location;
Project : Project_Id := No_Project;
Tree : Project_Tree_Ref := null);
- -- Add one main to the table.
- -- This is in general used to add the main files specified on the
- -- command line.
- -- Index is used for multi-unit source files, and indicates which unit
- -- within the source is concerned.
+ -- Add one main to the table. This is in general used to add the main
+ -- files specified on the command line. Index is used for multi-unit
+ -- source files, and indicates which unit in the source is concerned.
-- Location is the location within the project file (if a project file
- -- is used).
- -- Project and Tree indicate to which project the main should belong.
- -- In particular, for aggregate projects, this isn't necessarily the
- -- main project tree. These can be set to No_Project and null when not
- -- using projects.
+ -- is used). Project and Tree indicate to which project the main should
+ -- belong. In particular, for aggregate projects, this isn't necessarily
+ -- the main project tree. These can be set to No_Project and null when
+ -- not using projects.
procedure Delete;
-- Empty the table
-- If a single main file was defined, this subprogram indicates which
-- unit inside it is the main (case of a multi-unit source files).
-- Errors are raised if zero or more than one main file was defined,
- -- and Index is not 0.
- -- This subprogram is used for the handling of the command line switch.
+ -- and Index is non-zaero. This subprogram is used for the handling
+ -- of the command line switch.
function Next_Main return String;
function Next_Main return Main_Info;
- -- Moves the cursor forward and returns the new current entry.
- -- Returns No_File_And_Loc if there are no more mains in the table.
+ -- Moves the cursor forward and returns the new current entry. Returns
+ -- No_File_And_Loc if there are no more mains in the table.
function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural;
- -- Returns the number of mains in this project tree (if Tree is null,
- -- it returns the total number of project trees)
+ -- Returns the number of mains in this project tree (if Tree is null, it
+ -- returns the total number of project trees)
procedure Fill_From_Project
(Root_Project : Project_Id;
Project_Tree : Project_Tree_Ref);
-- If some main units were already added from the command line, check
-- that they all belong to the root project, and that they are full
- -- full paths rather than (partial) base names (e.g. no body suffix was
+ -- paths rather than (partial) base names (e.g. no body suffix was
-- specified).
end Mains;
type Source_Info_Format is (Format_Gprbuild, Format_Gnatmake);
package Queue is
- -- The queue of sources to be checked for compilation.
- -- There can be a single such queue per application.
+
+ -- The queue of sources to be checked for compilation. There can be a
+ -- single such queue per application.
type Source_Info (Format : Source_Info_Format := Format_Gprbuild) is
record
case Format is
- when Format_Gprbuild =>
- Tree : Project_Tree_Ref := null;
- Id : Source_Id := null;
-
- when Format_Gnatmake =>
- File : File_Name_Type := No_File;
- Unit : Unit_Name_Type := No_Unit_Name;
- Index : Int := 0;
- Project : Project_Id := No_Project;
+ when Format_Gprbuild =>
+ Tree : Project_Tree_Ref := null;
+ Id : Source_Id := null;
+
+ when Format_Gnatmake =>
+ File : File_Name_Type := No_File;
+ Unit : Unit_Name_Type := No_Unit_Name;
+ Index : Int := 0;
+ Project : Project_Id := No_Project;
end case;
end record;
-- Information about files stored in the queue. The exact information
-- depends on the builder, and in particular whether it only supports
-- project-based files (in which case we have a full Source_Id record).
- No_Source_Info : constant Source_Info :=
- (Format_Gprbuild, null, null);
+ No_Source_Info : constant Source_Info := (Format_Gprbuild, null, null);
procedure Initialize
(Queue_Per_Obj_Dir : Boolean;
-- Returns True if the queue is empty
function Is_Virtually_Empty return Boolean;
- -- Returns True if the queue is empty or if all object directories are
- -- busy.
+ -- Returns True if queue is empty or if all object directories are busy
procedure Insert (Source : Source_Info; With_Roots : Boolean := False);
function Insert
(Source : Source_Info; With_Roots : Boolean := False) return Boolean;
- -- Insert source in the queue.
- -- The second version returns False if the Source was already marked in
- -- the queue.
- -- If With_Roots is True and the source is in Format_Gprbuild mode (ie
- -- with a project), this procedure also includes the "Roots" for this
- -- main, ie all the other files that must be included in the library or
- -- binary (in particular to combine Ada and C files connected through
- -- pragma Export/Import). When the roots are computed, they are also
- -- stored in the corresponding Source_Id for later reuse by the binder.
+ -- Insert source in the queue. The second version returns False if the
+ -- Source was already marked in the queue. If With_Roots is True and the
+ -- source is in Format_Gprbuild mode (ie with a project), this procedure
+ -- also includes the "Roots" for this main, ie all the other files that
+ -- must be included in the library or binary (in particular to combine
+ -- Ada and C files connected through pragma Export/Import). When the
+ -- roots are computed, they are also stored in the corresponding
+ -- Source_Id for later reuse by the binder.
procedure Insert_Project_Sources
(Project : Project_Id;
Unique_Compile : Boolean);
-- Insert all the compilable sources of the project in the queue. If
-- All_Project is true, then all sources from imported projects are also
- -- inserted.
- -- Unique_Compile should be true if "-u" was specified on the command
- -- line: if True and some files were given on the command line), only
- -- those files will be compiled (so Insert_Project_Sources will do
+ -- inserted. Unique_Compile should be true if "-u" was specified on the
+ -- command line: if True and some files were given on the command line),
+ -- only those files will be compiled (so Insert_Project_Sources will do
-- nothing). If True and no file was specified on the command line, all
- -- files of the project(s) will be compiled.
- -- This procedure also processed aggregated projects.
+ -- files of the project(s) will be compiled. This procedure also
+ -- processed aggregated projects.
procedure Insert_Withed_Sources_For
(The_ALI : ALI.ALI_Id;
-------------------
procedure Output_Header (T : Character) is
- Loc : Source_Ptr := No_Location;
+ Loc : Source_Ptr := No_Location;
-- Node whose sloc is used for the decision
begin
when 'G' | 'P' =>
- -- For entry, the token sloc is from the N_Entry_Body.
- -- For PRAGMA, we must get the location from the pragma node.
+ -- For entry, the token sloc is from the N_Entry_Body. For
+ -- PRAGMA, we must get the location from the pragma node.
-- Argument N is the pragma argument, and we have to go up two
-- levels (through the pragma argument association) to get to
-- the pragma node itself.
Last => False);
if T = 'P' then
- -- For pragmas we also must make an entry in the hash table
- -- for later access by Set_SCO_Pragma_Enabled. We set the
- -- pragma as disabled now, the call will change C2 to 'e'
- -- to enable the pragma header entry.
+
+ -- For pragmas we also must make an entry in the hash table for
+ -- later access by Set_SCO_Pragma_Enabled. We set the pragma as
+ -- disabled now, the call will change C2 to 'e' to enable the
+ -- pragma header entry.
SCO_Table.Table (SCO_Table.Last).C2 := 'd';
Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
Traverse_Generic_Instantiation (Lu);
when others =>
+
-- All other cases of compilation units (e.g. renamings), generate
-- no SCO information.
declare
Cond : constant Node_Id :=
Condition (Entry_Body_Formal_Part (N));
+
begin
Set_Statement_Entry;
+
if Present (Cond) then
Process_Decisions_Defer (Cond, 'G');
end if;
+
Traverse_Subprogram_Or_Task_Body (N);
end;
Flags : Processing_Flags)
is
Data : Tree_Processing_Data :=
- (Tree => Tree,
- Node_Tree => Node_Tree,
- Flags => Flags);
+ (Tree => Tree,
+ Node_Tree => Node_Tree,
+ Flags => Flags);
Project_Files : constant Prj.Variable_Value :=
Prj.Util.Value_Of
Project_Path_For_Aggregate : Prj.Env.Project_Search_Path;
- procedure Found_Project_File
- (Path : Path_Information;
- Rank : Natural);
+ procedure Found_Project_File (Path : Path_Information; Rank : Natural);
-- Called for each project file aggregated by Project
procedure Expand_Project_Files is
-- Found_Project_File --
------------------------
- procedure Found_Project_File
- (Path : Path_Information;
- Rank : Natural)
- is
+ procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
pragma Unreferenced (Rank);
+
begin
if Path.Name /= Project.Path.Name then
Debug_Output ("Aggregates: ", Name_Id (Path.Display_Name));
Remove_Source_Dirs : Boolean := False;
procedure Add_To_Or_Remove_From_Source_Dirs
- (Path : Path_Information;
- Rank : Natural);
+ (Path : Path_Information;
+ Rank : Natural);
-- When Removed = False, the directory Path_Id to the list of
-- source_dirs if not already in the list. When Removed = True,
-- removed directory Path_Id if in the list.
---------------------------------------
procedure Add_To_Or_Remove_From_Source_Dirs
- (Path : Path_Information;
- Rank : Natural)
+ (Path : Path_Information;
+ Rank : Natural)
is
- List : String_List_Id;
- Prev : String_List_Id;
- Rank_List : Number_List_Index;
- Prev_Rank : Number_List_Index;
- Element : String_Element;
+ List : String_List_Id;
+ Prev : String_List_Id;
+ Rank_List : Number_List_Index;
+ Prev_Rank : Number_List_Index;
+ Element : String_Element;
begin
Prev := Nil_String;
((not Source_Files.Default
and then Source_Files.Values = Nil_String)
or else
- (not Source_Dirs.Default
- and then Source_Dirs.Values = Nil_String)
+ (not Source_Dirs.Default
+ and then Source_Dirs.Values = Nil_String)
or else
- (not Languages.Default
- and then Languages.Values = Nil_String))
+ (not Languages.Default
+ and then Languages.Values = Nil_String))
and then Project.Extends = No_Project;
-- Start of processing for Get_Directories
New_Value : Variable_Value)
is
Name : constant Name_Id := Name_Of (Current_Item, Node_Tree);
+
Is_Attribute : constant Boolean :=
Kind_Of (Current_Item, Node_Tree) =
N_Attribute_Declaration;
+
Var : Variable_Id := No_Variable;
begin
procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is
Success : Boolean;
- Proj : Project_List;
pragma Warnings (Off, Success);
+ Proj : Project_List;
+
begin
if not Debug.Debug_Flag_N then
if Project_Tree /= null then
Proj.Project.Config_File_Name := No_Path;
Proj.Project.Config_File_Temp := False;
end if;
+
Proj := Proj.Next;
end loop;
end if;
procedure Free (Tree : in out Project_Tree_Ref) is
procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ Ada.Unchecked_Deallocation
+ (Project_Tree_Data, Project_Tree_Ref);
+
+ procedure Unchecked_Free is new
+ Ada.Unchecked_Deallocation
(Project_Tree_Appdata'Class, Project_Tree_Appdata_Access);
begin
----------------
function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
- P : Project_List := Tree.Projects;
+ P : Project_List;
+
begin
Name_Len := 0;
Add_Str_To_Name_Buffer ("Tree [");
+ P := Tree.Projects;
while P /= null loop
if P /= Tree.Projects then
Add_Char_To_Name_Buffer (',');
-- Data for a project tree
function Debug_Name (Tree : Project_Tree_Ref) return Name_Id;
- -- If debug traces are activated, return an identitier for the
- -- project tree. This modifies Name_Buffer
+ -- If debug traces are activated, return an identitier for the project
+ -- tree. This modifies Name_Buffer.
procedure Expect (The_Token : Token_Type; Token_Image : String);
-- Check that the current token is The_Token. If it is not, then output
-- whether a project was already processed for instance.
generic
- with procedure Action (Project : Project_Id; Tree : Project_Tree_Ref);
+ with procedure Action (Project : Project_Id; Tree : Project_Tree_Ref);
procedure For_Project_And_Aggregated
(Root_Project : Project_Id;
Root_Tree : Project_Tree_Ref);
-- Does nothing if Debug.Debug_Flag_N is set
procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref);
- -- Delete all temporary config files.
- -- Does nothing if Debug.Debug_Flag_N is set or if Project_Tree is null.
- -- This initially came from gnatmake
+ -- Delete all temporary config files. Does nothing if Debug.Debug_Flag_N is
+ -- set or if Project_Tree is null. This initially came from gnatmake
-- ??? Should this be combined with Delete_All_Temp_Files above
procedure Delete_Temporary_File
Path : Path_Name_Type);
-- Delete a temporary file from the disk. The file is also removed from the
-- list of temporary files to delete at the end of the program, in case
- -- another program running on the same machine has recreated it.
- -- Does nothing if Debug.Debug_Flag_N is set
+ -- another program running on the same machine has recreated it. Does
+ -- nothing if Debug.Debug_Flag_N is set
Virtual_Prefix : constant String := "v$";
-- The prefix for virtual extending projects. Because of the '$', which is
procedure Debug_Increase_Indent
(Str : String := ""; Str2 : Name_Id := No_Name);
procedure Debug_Decrease_Indent (Str : String := "");
- -- Increase or decrease the indentation level for debug traces.
- -- This indentation level only affects output done through Debug_Output.
+ -- Increase or decrease the indentation level for debug traces. This
+ -- indentation level only affects output done through Debug_Output.
private
* Scenarios in Projects::
* Library Projects::
* Project Extension::
+* Aggregate Projects::
* Project File Reference::
@end menu
the file is searched for exactly as written in the @code{with} clause,
that is with no extension.
+As mentioned above, the path after a @code{with} has to be a literal
+string, and you cannot use concatenation, or lookup the value of external
+variables to change the directories from which a project is loaded.
+A solution if you need something like this is to use aggregate projects
+(@pxref{Aggregate Projects}).
+
@cindex project path
When a relative path or a base name is used, the
project files are searched relative to each of the directories in the
considered for recompilation, including the sources of @file{b.gpr} that are
impacted by the changes in @code{A1} and @code{C1}.
+@c ---------------------------------------------
+@node Aggregate Projects
+@section Aggregate Projects
+@c ---------------------------------------------
+
+@noindent
+
+Aggregate projects are an extension of the project paradigm, and are
+meant to solve a few specific use cases that cannot be solved directly
+using standard projects. This section will go over a few of these use
+cases to try and explain what you can use aggregate projects for.
+
+@subsection Building all main units from a single project tree
+
+Most often, an application is organized into modules and submodules,
+which are very conveniently represented as a project tree or graph
+(the root project A @code{with}s the projects for each modules (say B and C),
+which in turn @code{with} projects for submodules.
+
+Very often, modules will build their own executables (for testing
+purposes for instance), or libraries (for easier reuse in various
+contexts).
+
+However, if you build your project through gnatmake or gprbuild, using
+a syntax similar to
+
+@smallexample
+ gprbuild -PA.gpr
+@end smallexample
+
+this will only rebuild the main units of project A, not those of the
+imported projects B and C. Therefore you have to spawn several
+gnatmake commands, one per project, to build all executables.
+This is a little inconvenient, but more importantly is inefficient
+(since gnatmake needs to do duplicate work to ensure that sources are
+up-to-date, and cannot easily compile things in parallel when using
+the -j switch).
+
+Also libraries are always rebuild when building a project.
+
+You could therefore define an aggregate project Agg that groups A, B
+and C. Then, when you build with
+
+@smallexample
+ gprbuild -PAgg.gpr
+@end smallexample
+
+this will build all main units from A, B and C.
+
+@smallexample @c projectfile
+ aggregate project Agg is
+ for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
+ end Agg;
+@end smallexample
+
+If B or C do not define any main unit (through their Main
+attribute), all their sources are build. When you do not group them
+in the aggregate project, only those sources that are needed by A
+will be build.
+
+If you add a main unit to a project P not already explicitly referenced in the
+aggregate project, you will need to add "p.gpr" in the list of project
+files for the aggregate project, or the main unit will not be built when
+building the aggregate project.
+
+@subsection Building a set of projects with a single command
+
+One other case is when you have multiple applications and libraries
+that are build independently from each other (but they can be build in
+parallel). For instance, you have a project tree rooted at A, and
+another one (which might share some subprojects) rooted at B.
+
+Using only gprbuild, you could do
+
+@smallexample
+ gprbuild -PA.gpr
+ gprbuild -PB.gpr
+@end smallexample
+
+to build both. But again, gprbuild has to do some duplicate work for
+those files that are shared between the two, and cannot truly build
+things in parallel efficiently.
+
+If the two projects are really independent, share no sources other
+than through a common subproject, and have no source files with a
+common basename, you could create a project C that imports A and
+B. But these restrictions are often too strong, and one has to build
+them independently. An aggregate project does not have these
+limitations, and can aggregate two project trees that have common
+sources.
+
+@smallexample
+Aggregate projects can group projects with duplicate file names
+@end smallexample
+
+This scenario is particularly useful in environment like VxWork 653
+where the applications running in the multiple partitions can be build
+in parallel through a single gprbuild command. This also works nicely
+with Annex E.
+
+@smallexample
+ Aggregate projects can be used to build multiple partitions
+@end smallexample
+
+@subsection Define a build environment
+
+The environment variables at the time you launch gprbuild or gprbuild
+will influence the view these tools have of the project (PATH to find
+the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the
+projects, environment variables that are referenced in project files
+through the "external" statement,...). Several command line switches
+can be used to override those (-X or -aP), but on some systems and
+with some projects, this might make the command line too long, and on
+all systems often make it hard to read.
+
+An aggregate project can be used to set the environment for all
+projects build through that aggregate. One of the nice aspects is that
+you can put the aggregate project under configuration management, and
+make sure all your user have a consistent environment when
+building. The syntax looks like
+
+@smallexample @c projectfile
+ aggregate project Agg is
+ for Project_Files use ("A.gpr", "B.gpr");
+ for Project_Path use ("../dir1", "../dir1/dir2");
+ for External ("BUILD") use "PRODUCTION";
+
+ package Builder is
+ for Switches ("Ada") use ("-q");
+ end Builder;
+ end Agg;
+@end smallexample
+
+One of the often requested features in projects is to be able to
+reference external variables in @code{with} statements, as in
+
+@smallexample @c projectfile
+ with external("SETUP") & "path/prj.gpr"; -- ILLEGAL
+ project MyProject is
+ ...
+ end MyProject;
+@end smallexample
+
+For various reasons, this isn't authorized. But using aggregate
+projects provide an elegant solution. For instance, you could
+use a project file like:
+
+@smallexample @c projectfile
+aggregate project Agg is
+ for Project_Path use (external("SETUP") % "path");
+ for Project_Files use ("myproject.gpr");
+end Agg;
+
+
+with "prj.gpr"; -- searched on Agg'Project_Path
+project MyProject is
+ ...
+end MyProject;
+@end smallexample
+
+@subsection Performance improvements in builder
+
+The loading of aggregate projects is optimized in gprbuild and
+gnatmake, so that all files are searched for only once on the disk
+(thus reducing the number of system calls and contributing to faster
+compilation times especially on systems with sources on remote
+servers). As part of the loading, gprbuild and gnatmake compute how
+and where a source file should be compiled, and even if it is found
+several times in the aggregated projects it will be compiled only
+once.
+
+Since there is no ambiguity as to which switches should be used, files
+can be compiled in parallel (through the usual -j switch) and this can
+be done while maximizing the use of CPUs (compared to launching
+multiple gprbuild and gnatmake commands in parallel).
+
+@subsection Syntax of aggregate projects
+
+An aggregate project follows the general syntax of project files. The
+recommended extension is still @file{.gpr}. However, a special
+@code{aggregate} qualifier must be put before the keyword
+@code{project}.
+
+An aggregate project cannot @code{with} any other project (standard or
+aggregate), except an abstract project which can be used to share
+attribute values. Building other aggregate projects from an aggregate
+project is done through the Project_Files attribute (see below).
+
+An aggregate project does not have any source files directly (only
+through other standard projects). Therefore a number of the standard
+attributes and packages are forbidden in an aggregate project. Here is the
+(non exhaustive) list:
+
+@itemize @bullet
+@item Languages
+@item Source_files, Source_List_File and other attributes dealing with
+ list of sources.
+@item Source_Dirs, Exec_Dir and Object_Dir
+@item Library_Dir, Library_Name and other library-related attributes
+@item Main
+@item Roots
+@item Externally_Built
+@item Inherit_Source_Path
+@item Excluded_Source_Dirs
+@item Locally_Removed_Files
+@item Excluded_Source_Fies
+@item Excluded_Source_List_File
+@item Interfaces
+@end itemize
+
+The only package that is authorized (albeit optional) is
+Builder. Other packages (in particular Compiler, Binder and Linker)
+are forbidden. It is an error to have any of these
+(and such an error prevents the proper loading of the aggregate
+project).
+
+Three new attributes have been created, which can only be used in the
+context of aggregate projects:
+
+@table @asis
+@item @b{Project_Files}:
+@cindex @code{Project_Files}
+
+This attribute is compulsory (or else we are not aggregating any project,
+and thus not doing anything). It specifies a list of @file{.gpr} files
+that are grouped in the aggregate. The list may be empty. The project
+files can be either other aggregate projects, or standard projects. When
+grouping standard projects, you can have both the root of a project tree
+(and you do not need to specify all its imported projects), and any project
+within the tree.
+
+Basically, the idea is to specify all those projects that have
+main units you want to build and link, or libraries you want to
+build. You can even specify projects that do not use the Main
+attribute nor the @code{Library_*} attributes, and the result will be to
+build all their source files (not just the ones needed by other
+projects).
+
+The file can include paths (absolute or relative). Paths are
+relative to the location of the aggregate project file itself (if
+you use a base name, we expect to find the .gpr file in the same
+directory as the aggregate project file). The extension @file{.gpr} is
+mandatory, since this attribute contains file names, not project names.
+
+Paths can also include the @code{"*"} and @code{"**"} globbing patterns. The
+latter indicates that any subdirectory (recursively) will be
+searched for matching files. The latter (@code{"**"}) can only occur at the
+last position in the directory part (ie @code{"a/**/*.gpr"} is supported, but
+not @code{"**/a/*.gpr"}). Starting the pattern with @code{"**"} is equivalent
+to starting with @code{"./**"}.
+
+For now, the pattern @code{"*"} is only allowed in the filename part, not
+in the directory part. This is mostly for efficiency reasons to limit the
+number of system calls that are needed.
+
+Here are a few valid examples:
+
+@smallexample @c projectfile
+ for Project_Files use ("a.gpr", "subdir/b.gpr");
+ -- two specific projects relative to the directory of agg.gpr
+
+ for Project_Files use ("**/*.gpr");
+ -- all projects recursively
+@end smallexample
+
+@item @b{Project_Path}:
+@cindex @code{Project_Path}
+
+This attribute can be used to specify a list of directories in
+which to look for project files in @code{with} statements.
+
+When you specify a project in Project_Files
+say @code{"x/y/a.gpr"}), and this projects imports a project "b.gpr", only
+b.gpr is searched in the project path. a.gpr must be exactly at
+<dir of the aggregate>/x/y/a.gpr.
+
+This attribute, however, does not affect the search for the aggregated
+project files specified with @code{Project_Files}.
+
+Each aggregate project has its own (that is if agg1.gpr includes
+agg2.gpr, they can potentially both have a different project path).
+This project path is defined as the concatenation, in that order, of
+the current directory, followed by the command line -aP switches,
+then the directories from the Project_Path attribute, then the
+directories from the GPR_PROJECT_PATH and ADA_PROJECT_PATH env.
+variables, and finally the predefined directories.
+
+In the example above, agg2.gpr's project path is not influenced by
+the attribute agg1'Project_Path, nor is agg1 influenced by
+agg2'Project_Path.
+
+This can potentially lead to errors. In the following example:
+
+@smallexample
+ +---------------+ +----------------+
+ | Agg1.gpr |-=--includes--=-->| Agg2.gpr |
+ | 'project_path| | 'project_path |
+ | | | |
+ +---------------+ +----------------+
+ : :
+ includes includes
+ : :
+ v v
+ +-------+ +---------+
+ | P.gpr |<---------- withs --------| Q.gpr |
+ +-------+---------\ +---------+
+ | |
+ withs |
+ | |
+ v v
+ +-------+ +---------+
+ | R.gpr | | R'.gpr |
+ +-------+ +---------+
+@end smallexample
+
+When looking for p.gpr, both aggregates find the same physical file on
+the disk. However, it might happen that with their different project
+paths, both aggregate projects would in fact find a different r.gpr.
+Since we have a common project (p.gpr) "with"ing two different r.gpr,
+this will be reported as an error by the builder.
+
+Directories are relative to the location of the aggregate project file.
+
+Here are a few valid examples:
+
+@smallexample @c projectfile
+ for Project_Path use ("/usr/local/gpr", "gpr/");
+@end smallexample
+
+@item @b{External}:
+@cindex @code{External}
+
+This attribute can be used to set the value of environment
+variables as retrieved through the @code{external} statement
+in projects. It does not affect the environment variables
+themselves (so for instance you cannot use it to change the value
+of your PATH as seen from the spawned compiler).
+
+This attribute affects the external values as seen in the rest of
+the aggreate projects, and in the aggregated projects.
+
+The exact value of external a variable comes from one of three
+sources (each level overrides the previous levels):
+
+@itemize @bullet
+@item An External attribute in aggregate project, for instance
+ @code{for External ("BUILD_MODE") use "DEBUG"};
+
+@item Environment variables
+
+These override the value given by the attribute, so that
+users can override the value set in the (presumably shared
+with others in his team) aggregate project.
+
+@item The -X command line switch to gprbuild and gnatmake
+
+This always takes precedence.
+
+@end itemize
+
+This attribute is only taken into account in the main aggregate
+project (i.e. the one specified on the command line to gprbuild or
+natmake), and ignored in other aggregate projects. It is invalid
+in standard projects.
+The goal is to have a consistent value in all
+projects that are build through the aggregate, which would not
+be the case in the diamond case: A groups the aggregate
+projects B and C, which both (either directly or indirectly)
+build the project P. If B and C could set different values for
+the environment variables, we would have two different views of
+P, which in particular might impact the list of source files in P.
+
+@end table
+
+@subsection package Builder in aggregate projects
+
+As we mentioned before, only the package Builder can be specified in
+an aggregate project. In this package, only the following attributes
+are valid:
+
+@table @asis
+@item @b{Switches}:
+@cindex @code{Switches}
+This attribute gives the list of switches to use for the builder
+(gprbuild or gnatmake), depending on the language of the main file.
+For instance,
+
+@smallexample @c projectfile
+for Switches ("Ada") use ("-d", "-p");
+for Switches ("C") use ("-p");
+@end smallexample
+
+These switches are only read from the main aggregate project (the
+one passed on the command line), and ignored in all other aggregate
+projects or projects.
+
+It can only contain builder switches, not compiler switches.
+
+@item @b{Global_Compilation_Switches}
+@cindex @code{Global_Compilation_Switches}
+
+This attribute gives the list of compiler switches for the various
+languages. For instance,
+
+@smallexample @c projectfile
+for Global_Compilation_Switches ("Ada") use ("-O1", "-g");
+for Global_Compilation_Switches ("C") use ("-O2");
+@end smallexample
+
+This attribute is only taken into account in the aggregate project
+specified on the command line, not in other aggregate projects.
+
+In the projects grouped by that aggregate, the attribute
+Builder.Global_Compilation_Switches is also ignored. However, the
+attribute Compiler.Default_Switches will be taken into account (but
+that of the aggregate have higher priority). The attribute
+Compiler.Switches is also taken into account and can be used to
+override the switches for a specific file. As a result, it always
+has priority.
+
+The rules are meant to avoid ambiguities when compiling. For
+instance, aggregate project Agg groups the projects A and B, that
+both depend on C. Here is an extra for all of these projects:
+
+@smallexample @c projectfile
+ aggregate project Agg is
+ for Project_Files use ("a.gpr", "b.gpr");
+ package Builder is
+ for Global_Compilation_Switches ("Ada") use ("-O2");
+ end Builder;
+ end Agg;
+
+ with "c.gpr";
+ project A is
+ package Builder is
+ for Global_Compilation_Switches ("Ada") use ("-O1");
+ -- ignored
+ end Builder;
+
+ package Compiler is
+ for Default_Switches ("Ada") use ("-O1", "-g");
+ for Switches ("a_file1.adb") use ("-O0");
+ end Compiler;
+ end A;
+
+ with "c.gpr";
+ project B is
+ package Compiler is
+ for Default_Switches ("Ada") use ("-O0");
+ end Compiler;
+ end B;
+
+ project C is
+ package Compiler is
+ for Default_Switches ("Ada") use ("-O3, "-gnatn");
+ for Switches ("c_file1.adb") use ("-O0", "-g");
+ end Compiler;
+ end C;
+@end smallexample
+
+then the following switches are used:
+
+@itemize @bullet
+@item all files from project A except a_file1.adb are compiled
+ with "-O2 -g", since the aggregate project has priority.
+@item the file a_file1.adb is compiled with
+ "-O0", since the Compiler.Switches has priority
+@item all files from project B are compiled with
+ "-O2", since the aggregate project has priority
+@item all files from C are compiled with "-O2 -gnatn", except for
+ c_file1.adb which is compiled with "-O0 -g"
+@end itemize
+
+Even though C is seen through two paths (through A and through
+B), the switches used by the compiler are unambiguous.
+
+@item @b{Global_Configuration_Pragmas}
+@cindex @code{Global_Configuration_Pragmas}
+
+This attribute can be used to specify a file containing
+configuration pragmas, to be passed to the compiler. Since we
+ignore the package Builder in other aggregate projects and projects,
+only those pragmas defined in the main aggregate project will be
+taken into account.
+
+Projects can locally add to those by using the
+@code{Compiler.Local_Configuration_Pragmas} attribute if they need.
+
+@end table
+
+For projects that are build through the aggregate, the package Builder
+is ignored, except for the Executable attribute which specifies the
+name of the executables resulting from the link of the main units, and
+for the Executable_Suffix.
+
@c ---------------------------------------------
@node Project File Reference
@section Project File Reference
if Nkind (Nod) = N_Identifier then
return;
- elsif Nkind (Nod) = N_Selected_Component
- or else Nkind (Nod) = N_Expanded_Name
- then
+ elsif Nkind_In (Nod, N_Selected_Component, N_Expanded_Name) then
Check_Unit_Name (Prefix (Nod));
if Nkind (Selector_Name (Nod)) = N_Identifier then
return Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
elsif Nkind (C1) in N_Binary_Op then
- return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
- and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
+ return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
+ and then
+ Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
elsif Nkind (C1) = N_Null then
return True;
Assoc : Node_Id;
Choice : Node_Id;
Val : Uint;
- Err : Boolean := False;
+
+ Err : Boolean := False;
-- Set True to avoid cascade errors and crashes on incorrect source code
Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
Err := True;
elsif Nkind (Choice) = N_Range then
+
-- ??? should allow zero/one element range here
+
Error_Msg_N ("range not allowed here", Choice);
Err := True;
else
Analyze_And_Resolve (Choice, Enumtype);
+
if Error_Posted (Choice) then
Err := True;
end if;
then
Error_Msg_N ("subtype name not allowed here", Choice);
Err := True;
+
-- ??? should allow static subtype with zero/one entry
elsif Etype (Choice) = Base_Type (Enumtype) then
-- Visibility and Name Resolution --
------------------------------------
- -- This package handles name resolution and the collection of
+ -- This package handles name resolution and the collection of possible
-- interpretations for overloaded names, prior to overload resolution.
-- Name resolution is the process that establishes a mapping between source
and then RTU_Loaded (Ada_Tags)
and then
((RTE_Available (RE_Dispatch_Table_Wrapper)
- and then Scope (Selector) =
+ and then Scope (Selector) =
RTE (RE_Dispatch_Table_Wrapper))
- or else
+ or else
(RTE_Available (RE_No_Dispatch_Table_Wrapper)
- and then Scope (Selector) =
+ and then Scope (Selector) =
RTE (RE_No_Dispatch_Table_Wrapper)))
then
C_Etype := Empty;
else
C_Etype :=
- Build_Actual_Subtype_Of_Component (
- Etype (Selector), N);
+ Build_Actual_Subtype_Of_Component
+ (Etype (Selector), N);
end if;
else
then
pragma Assert
((Ekind (Subp) = E_Function
- and then Is_Dispatching_Operation (Old_Subp)
- and then Is_Null_Extension (Base_Type (Etype (Subp))))
+ and then Is_Dispatching_Operation (Old_Subp)
+ and then Is_Null_Extension (Base_Type (Etype (Subp))))
or else
(Ekind (Subp) = E_Procedure
- and then Is_Dispatching_Operation (Old_Subp)
- and then Present (Alias (Old_Subp))
- and then Is_Null_Interface_Primitive
+ and then Is_Dispatching_Operation (Old_Subp)
+ and then Present (Alias (Old_Subp))
+ and then Is_Null_Interface_Primitive
(Ultimate_Alias (Old_Subp)))
or else Get_TSS_Name (Subp) = TSS_Stream_Read
or else Get_TSS_Name (Subp) = TSS_Stream_Write);
elsif Has_Controlled_Component (Tagged_Type)
and then
- (Chars (Subp) = Name_Initialize
- or else
- Chars (Subp) = Name_Adjust
- or else
- Chars (Subp) = Name_Finalize
- or else
- Chars (Subp) = Name_Finalize_Address)
+ (Chars (Subp) = Name_Initialize or else
+ Chars (Subp) = Name_Adjust or else
+ Chars (Subp) = Name_Finalize or else
+ Chars (Subp) = Name_Finalize_Address)
then
declare
F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
declare
Typ : constant Entity_Id := Etype (First_Formal (Ent));
Init : Entity_Id;
+
begin
if not Is_Controlled (Typ) then
return;
Insert_Action (Declaration_Node (E),
Make_Object_Declaration (Loce,
Defining_Identifier => Ent,
- Object_Definition =>
+ Object_Definition =>
New_Occurrence_Of (Standard_Integer, Loce),
- Expression => Make_Integer_Literal (Loc, Uint_0)));
+ Expression =>
+ Make_Integer_Literal (Loc, Uint_0)));
-- Set elaboration flag at the point of the body
Insert_Elab_Check (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
- Prefix => New_Occurrence_Of (E, Loc)));
+ Prefix => New_Occurrence_Of (E, Loc)));
end if;
-- Generate the warning
return Unknown;
end if;
end if;
- else
- -- If the range of either operand cannot be determined,
- -- nothing further can be inferred.
+ -- If the range of either operand cannot be determined, nothing
+ -- further can be inferred.
+ else
return Unknown;
end if;
end;
-- entities are supported by the VM.
if Convention (Subprogram_Def) /= Convention_CIL
- and then Convention (Subprogram_Def) /= Convention_Java
+ and then
+ Convention (Subprogram_Def) /= Convention_Java
then
Check_Duplicated_Export_Name (Link_Nam);
end if;
-- Create elaboration flag
- Elab_Ent :=
- Make_Defining_Identifier (Loc, Chars => Name_Find);
+ Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
Set_Elaboration_Entity (Spec_Id, Elab_Ent);
Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Elab_Ent,
- Object_Definition =>
- New_Occurrence_Of (Standard_Integer, Loc),
- Expression =>
- Make_Integer_Literal (Loc, Uint_0));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Elab_Ent,
+ Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Make_Integer_Literal (Loc, Uint_0));
Push_Scope (Standard_Standard);
Add_Global_Declaration (Decl);
return False;
end if;
- -- First treat specially string literals, as the lower bound and length
+ -- First treat string literals specially, as the lower bound and length
-- of string literals are not stored like those of arrays.
-- A string literal always has static bounds
return False;
end if;
- if Is_OK_Static_Expression (Low)
- and then Is_OK_Static_Expression (High)
+ if Is_OK_Static_Expression (Low)
+ and then
+ Is_OK_Static_Expression (High)
then
null;
else
if Nkind (Decl) = N_Incomplete_Type_Declaration then
Match := Defining_Identifier (Decl);
end if;
+
else
if Nkind_In (Decl, N_Private_Extension_Declaration,
N_Private_Type_Declaration)
return Empty;
end Inspect_Decls;
+ -- Local variables
+
Prev : Entity_Id;
-- Start of processing for Incomplete_Or_Partial_View
-- previous errors (particularly in -gnatq mode).
function Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- -- E is a type entity. The result is True when temporaries of this type
+ -- Id is a type entity. The result is True when temporaries of this type
-- need to be wrapped in a transient scope to be reclaimed properly when a
-- secondary stack is in use. Examples of types requiring such wrapping are
-- controlled types and variable-sized types including unconstrained
projects / gcc.git / commitdiff