This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
committed: Ada updates
- From: Arnaud Charlet <charlet at ACT-Europe dot FR>
- To: gcc-patches at gcc dot gnu dot org
- Date: Mon, 8 Dec 2003 11:34:09 +0100
- Subject: committed: Ada updates
Tested on x86-linux
--
2003-12-08 Jerome Guitton <guitton@act-europe.fr>
* 5ytiitho.adb, 5zthrini.adb, 5ztiitho.adb, i-vthrea.adb,
i-vthrea.ads, s-tpae65.adb, s-tpae65.ads: Cleanup: Remove a bunch of
obsolete files.
* Makefile.in: (rts-ravenscar): Generate an empty libgnat.a.
(rts-zfp): Ditto.
2003-12-08 Robert Dewar <dewar@gnat.com>
* 7sintman.adb: Minor reformatting
* bindgen.adb: Configurable_Run_Time mode no longer suppresses the
standard linker options to get standard libraries linked. We now plan
to provide dummy versions of these libraries to match the appropriate
configurable run-time (e.g. if a library is not needed at all, provide
a dummy empty library).
* targparm.ads: Configurable_Run_Time mode no longer affects linker
options (-L parameters and standard libraries). What we plan to do is
to provide dummy libraries where the libraries are not required.
* gnatbind.adb: Minor comment improvement
2003-12-08 Javier Miranda <miranda@gnat.com>
* exp_aggr.adb (Build_Record_Aggr_Code): Do not remove the expanded
aggregate in the parent. Otherwise constants with limited aggregates
are not supported. Add new formal to pass the component type (Ctype).
It is required to call the corresponding IP subprogram in case of
default initialized components.
(Gen_Assign): In case of default-initialized component, generate a
call to the IP subprogram associated with the component.
(Build_Record_Aggr_Code): Remove the aggregate from the parent in case
of aggregate with default initialized components.
(Has_Default_Init_Comps): Improve implementation to recursively check
all the present expressions.
* exp_ch3.ads, exp_ch3.adb (Build_Initialization_Call): Add new formal
to indicate that the initialization call corresponds to a
default-initialized component of an aggregate.
In case of default initialized aggregate with tasks this parameter is
used to generate a null string (this is just a workaround that must be
improved later). In case of discriminants, this parameter is used to
generate a selected component node that gives access to the discriminant
value.
* exp_ch9.ads, exp_ch9.adb (Build_Task_Allocate_Block_With_Stmts): New
subprogram, based on Build_Task_Allocate_Block, but adapted to expand
allocated aggregates with default-initialized components.
* par-ch4.adb (P_Aggregate_Or_Paren_Expr): Improve error message if
the box notation is used in positional aggregates.
2003-12-08 Samuel Tardieu <tardieu@act-europe.fr>
* lib.ads: Fix typo in comment
2003-12-08 Vincent Celier <celier@gnat.com>
* prj.adb (Project_Empty): New component Unkept_Comments
(Scan): Remove procedure; moved to Prj.Err.
* prj.ads (Project_Data): New Boolean component Unkept_Comments
(Scan): Remove procedure; moved to Prj.Err.
* prj-dect.adb: Manage comments for the different declarations.
* prj-part.adb (With_Record): New component Node
(Parse): New Boolean parameter Store_Comments, defaulted to False.
Set the scanner to return ends of line and comments as tokens, if
Store_Comments is True.
(Pre_Parse_Context_Clause): Create the N_With_Clause nodes so that
comments are associated with these nodes. Store the node IDs in the
With_Records.
(Post_Parse_Context_Clause): Use the N_With_Clause nodes stored in the
With_Records.
(Parse_Single_Project): Call Pre_Parse_Context_Clause before creating
the N_Project node. Call Tree.Save and Tree.Reset before scanning the
current project. Call Tree.Restore afterwards. Set the various nodes
for comment storage (Next_End, End_Of_Line, Previous_Line,
Previous_End).
* prj-part.ads (Parse): New Boolean parameter Store_Comments,
defaulted to False.
* prj-pp.adb (Write_String): New Boolean parameter Truncated, defaulted
to False. When Truncated is True, truncate the string, never go to the
next line.
(Write_End_Of_Line_Comment): New procedure
(Print): Process comments for nodes N_With_Clause,
N_Package_Declaration, N_String_Type_Declaration,
N_Attribute_Declaration, N_Typed_Variable_Declaration,
N_Variable_Declaration, N_Case_Construction, N_Case_Item.
Process nodes N_Comment.
* prj-tree.ads, prj-tree.adb (Default_Project_Node): If it is a node
without comments and there are some comments, set the flag
Unkept_Comments to True.
(Scan): If there are comments, set the flag Unkept_Comments to True and
clear the comments.
(Project_Node_Kind): Add enum values N_Comment_Zones, N_Comment
(Next_End_Nodes: New table
(Comment_Zones_Of): New function
(Scan): New procedure; moved from Prj. Accumulate comments in the
Comments table and set end of line comments, comments after, after end
and before end.
(Add_Comments): New procedure
(Save, Restore, Seset_State): New procedures
(There_Are_Unkept_Comments): New function
(Set_Previous_Line_Node, Set_Previous_End_Node): New procedures
(Set_End_Of_Line, Set_Next_End_Node, Remove_Next_End_Node): New
procedures.
(First_Comment_After, First_Comment_After_End): New functions
(First_Comment_Before, First_Comment_Before_End): New functions
(Next_Comment): New function
(End_Of_Line_Comment, Follows_Empty_Line,
Is_Followed_By_Empty_Line): New functions
(Set_First_Comment_After, Set_First_Comment_After_End): New procedures
(Set_First_Comment_Before, Set_First_Comment_Before_End): New procedures
(Set_Next_Comment): New procedure
(Default_Project_Node): Associate comment before if the node can store
comments.
* scans.ads (Token_Type): New enumeration value Tok_Comment
(Comment_Id): New global variable
* scng.ads, scng.adb (Comment_Is_Token): New Boolean global variable,
defaulted to False.
(Scan): Store position of start of comment. If comments are tokens, set
Comment_Id and set Token to Tok_Comment when scanning a comment.
(Set_Comment_As_Token): New procedure
* sinput-p.adb: Update Copyright notice
(Source_File_Is_Subunit): Call Prj.Err.Scanner.Scan instead of Prj.Scan
that no longer exists.
2003-12-08 Javier Miranda <miranda@gnat.com>
* sem_aggr.adb: Add dependence on Exp_Tss package
Correct typo in comment
(Resolve_Aggregate): In case of array aggregates set the estimated
type of the aggregate before calling resolve. This is needed to know
the name of the corresponding IP in case of limited array aggregates.
(Resolve_Array_Aggregate): Delay the resolution to the expansion phase
in case of default initialized array components.
* sem_ch12.adb (Analyze_Formal_Object_Declaration): Allow limited
types. Required to give support to limited aggregates in generic
formals.
2003-12-08 Ed Schonberg <schonberg@gnat.com>
* sem_ch3.adb (Check_Initialization): For legality purposes, an
inlined body functions like an instantiation.
(Decimal_Fixed_Point_Declaration): Do not set kind of first subtype
until bounds are analyzed, to diagnose premature use of type.
* sem_util.adb (Wrong_Type): Improve error message when the type of
the expression is used prematurely.
2003-12-08 GNAT Script <nobody@gnat.com>
* Make-lang.in: Makefile automatically updated
--
Index: 7sintman.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/7sintman.adb,v
retrieving revision 1.7
diff -u -p -r1.7 7sintman.adb
--- 7sintman.adb 5 Dec 2003 10:24:04 -0000 1.7
+++ 7sintman.adb 8 Dec 2003 10:31:49 -0000
@@ -152,7 +152,7 @@ begin
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
+ -- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
@@ -178,9 +178,9 @@ begin
act.sa_flags := SA_SIGINFO;
-- Setting SA_SIGINFO asks the kernel to pass more than just the signal
- -- number argument to the handler when it is called. The set of extra
+ -- number argument to the handler when it is called. The set of extra
-- parameters typically includes a pointer to a structure describing
- -- the interrupted context. Although the Notify_Exception handler does
+ -- the interrupted context. Although the Notify_Exception handler does
-- not use this information, it is actually required for the GCC/ZCX
-- exception propagation scheme because on some targets (at least
-- alpha-tru64), the structure contents are not even filled when this
Index: bindgen.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/bindgen.adb,v
retrieving revision 1.16
diff -u -p -r1.16 bindgen.adb
--- bindgen.adb 14 Nov 2003 10:24:42 -0000 1.16
+++ bindgen.adb 8 Dec 2003 10:31:49 -0000
@@ -1774,22 +1774,18 @@ package body Bindgen is
end if;
end loop;
- -- Add a "-Ldir" for each directory in the object path. We skip this
- -- in Configurable_Run_Time mode, where we want more precise control
- -- of exactly what goes into the resulting object file
-
- if not Configurable_Run_Time_Mode then
- for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
- declare
- Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("-L");
- Add_Str_To_Name_Buffer (Dir.all);
- Write_Linker_Option;
- end;
- end loop;
- end if;
+ -- Add a "-Ldir" for each directory in the object path
+
+ for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
+ declare
+ Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
+ begin
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer ("-L");
+ Add_Str_To_Name_Buffer (Dir.all);
+ Write_Linker_Option;
+ end;
+ end loop;
-- Sort linker options
@@ -1845,7 +1841,7 @@ package body Bindgen is
-- files. The reason for this decision is that libraries referenced
-- by internal routines may reference these standard library entries.
- if not (Configurable_Run_Time_Mode or else Opt.No_Stdlib) then
+ if not Opt.No_Stdlib then
Name_Len := 0;
if Opt.Shared_Libgnat then
Index: exp_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_aggr.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_aggr.adb
--- exp_aggr.adb 20 Nov 2003 09:53:58 -0000 1.10
+++ exp_aggr.adb 8 Dec 2003 10:31:50 -0000
@@ -33,6 +33,7 @@ with Expander; use Expander;
with Exp_Util; use Exp_Util;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch9; use Exp_Ch9;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Itypes; use Itypes;
@@ -170,6 +171,7 @@ package body Exp_Aggr is
function Build_Array_Aggr_Code
(N : Node_Id;
+ Ctype : Entity_Id;
Index : Node_Id;
Into : Node_Id;
Scalar_Comp : Boolean;
@@ -397,6 +399,7 @@ package body Exp_Aggr is
function Build_Array_Aggr_Code
(N : Node_Id;
+ Ctype : Entity_Id;
Index : Node_Id;
Into : Node_Id;
Scalar_Comp : Boolean;
@@ -430,6 +433,9 @@ package body Exp_Aggr is
-- Into (Indices, Ind) := Expr;
--
-- Otherwise we call Build_Code recursively.
+ --
+ -- Ada0Y (AI-287): In case of default initialized component, Expr is
+ -- empty and we generate a call to the corresponding IP subprogram.
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
-- Nodes L and H must be side-effect free expressions.
@@ -656,7 +662,13 @@ package body Exp_Aggr is
Res : List_Id;
begin
- if Nkind (Parent (Expr)) = N_Component_Association
+ -- Ada0Y (AI-287): Do nothing else in case of default initialized
+ -- component
+
+ if not Present (Expr) then
+ return Lis;
+
+ elsif Nkind (Parent (Expr)) = N_Component_Association
and then Present (Loop_Actions (Parent (Expr)))
then
Append_List (Lis, Loop_Actions (Parent (Expr)));
@@ -692,15 +704,20 @@ package body Exp_Aggr is
F := Find_Final_List (Current_Scope);
end if;
else
- F := 0;
+ F := Empty;
end if;
if Present (Next_Index (Index)) then
return
Add_Loop_Actions (
Build_Array_Aggr_Code
- (Expr, Next_Index (Index),
- Into, Scalar_Comp, New_Indices, F));
+ (N => Expr,
+ Ctype => Ctype,
+ Index => Next_Index (Index),
+ Into => Into,
+ Scalar_Comp => Scalar_Comp,
+ Indices => New_Indices,
+ Flist => F));
end if;
-- If we get here then we are at a bottom-level (sub-)aggregate
@@ -713,7 +730,12 @@ package body Exp_Aggr is
Set_Assignment_OK (Indexed_Comp);
- if Nkind (Expr) = N_Qualified_Expression then
+ -- Ada0Y (AI-287): In case of default initialized component, Expr
+ -- is not present (and therefore we also initialize Expr_Q to empty)
+
+ if not Present (Expr) then
+ Expr_Q := Empty;
+ elsif Nkind (Expr) = N_Qualified_Expression then
Expr_Q := Expression (Expr);
else
Expr_Q := Expr;
@@ -723,34 +745,49 @@ package body Exp_Aggr is
and then Etype (N) /= Any_Composite
then
Comp_Type := Component_Type (Etype (N));
+ pragma Assert (Comp_Type = Ctype); -- AI-287
elsif Present (Next (First (New_Indices))) then
- -- This is a multidimensional array. Recover the component
- -- type from the outermost aggregate, because subaggregates
- -- do not have an assigned type.
+ -- Ada0Y (AI-287): Do nothing in case of default initialized
+ -- component because we have received the component type in
+ -- the formal parameter Ctype.
+ -- ??? I have added some assert pragmas to check if this new
+ -- formal can be used to replace this code in all cases.
+
+ if Present (Expr) then
+
+ -- This is a multidimensional array. Recover the component
+ -- type from the outermost aggregate, because subaggregates
+ -- do not have an assigned type.
- declare
- P : Node_Id := Parent (Expr);
+ declare
+ P : Node_Id := Parent (Expr);
- begin
- while Present (P) loop
+ begin
+ while Present (P) loop
- if Nkind (P) = N_Aggregate
- and then Present (Etype (P))
- then
- Comp_Type := Component_Type (Etype (P));
- exit;
+ if Nkind (P) = N_Aggregate
+ and then Present (Etype (P))
+ then
+ Comp_Type := Component_Type (Etype (P));
+ exit;
- else
- P := Parent (P);
- end if;
- end loop;
- end;
+ else
+ P := Parent (P);
+ end if;
+ end loop;
+ pragma Assert (Comp_Type = Ctype); -- AI-287
+ end;
+ end if;
end if;
- if Nkind (Expr_Q) = N_Aggregate
- or else Nkind (Expr_Q) = N_Extension_Aggregate
+ -- Ada0Y (AI-287): We only analyze the expression in case of non
+ -- default initialized components (otherwise Expr_Q is not present)
+
+ if Present (Expr_Q)
+ and then (Nkind (Expr_Q) = N_Aggregate
+ or else Nkind (Expr_Q) = N_Extension_Aggregate)
then
-- At this stage the Expression may not have been
-- analyzed yet because the array aggregate code has not
@@ -771,59 +808,73 @@ package body Exp_Aggr is
end if;
end if;
- -- Now generate the assignment with no associated controlled
- -- actions since the target of the assignment may not have
- -- been initialized, it is not possible to Finalize it as
- -- expected by normal controlled assignment. The rest of the
- -- controlled actions are done manually with the proper
- -- finalization list coming from the context.
+ -- Ada0Y (AI-287): In case of default initialized component, call
+ -- the initialization subprogram associated with the component type
- A :=
- Make_OK_Assignment_Statement (Loc,
- Name => Indexed_Comp,
- Expression => New_Copy_Tree (Expr));
+ if not Present (Expr) then
- if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
- Set_No_Ctrl_Actions (A);
- end if;
+ Append_List_To (L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Indexed_Comp,
+ Typ => Ctype,
+ With_Default_Init => True));
- Append_To (L, A);
+ else
- -- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for the Java VM
- -- where tags are implicit.
+ -- Now generate the assignment with no associated controlled
+ -- actions since the target of the assignment may not have
+ -- been initialized, it is not possible to Finalize it as
+ -- expected by normal controlled assignment. The rest of the
+ -- controlled actions are done manually with the proper
+ -- finalization list coming from the context.
- if Present (Comp_Type)
- and then Is_Tagged_Type (Comp_Type)
- and then not Java_VM
- then
A :=
Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Indexed_Comp),
- Selector_Name =>
- New_Reference_To (Tag_Component (Comp_Type), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (
- Access_Disp_Table (Comp_Type), Loc)));
+ Name => Indexed_Comp,
+ Expression => New_Copy_Tree (Expr));
+
+ if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
+ Set_No_Ctrl_Actions (A);
+ end if;
Append_To (L, A);
- end if;
- -- Adjust and Attach the component to the proper final list
- -- which can be the controller of the outer record object or
- -- the final list associated with the scope
+ -- Adjust the tag if tagged (because of possible view
+ -- conversions), unless compiling for the Java VM
+ -- where tags are implicit.
- if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
- Append_List_To (L,
- Make_Adjust_Call (
- Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Comp_Type,
- Flist_Ref => F,
- With_Attach => Make_Integer_Literal (Loc, 1)));
+ if Present (Comp_Type)
+ and then Is_Tagged_Type (Comp_Type)
+ and then not Java_VM
+ then
+ A :=
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Indexed_Comp),
+ Selector_Name =>
+ New_Reference_To (Tag_Component (Comp_Type), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (
+ Access_Disp_Table (Comp_Type), Loc)));
+
+ Append_To (L, A);
+ end if;
+
+ -- Adjust and Attach the component to the proper final list
+ -- which can be the controller of the outer record object or
+ -- the final list associated with the scope
+
+ if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
+ Append_List_To (L,
+ Make_Adjust_Call (
+ Ref => New_Copy_Tree (Indexed_Comp),
+ Typ => Comp_Type,
+ Flist_Ref => F,
+ With_Attach => Make_Integer_Literal (Loc, 1)));
+ end if;
end if;
return Add_Loop_Actions (L);
@@ -857,21 +908,29 @@ package body Exp_Aggr is
if Empty_Range (L, H) then
Append_To (S, Make_Null_Statement (Loc));
- -- The expression must be type-checked even though no component
- -- of the aggregate will have this value. This is done only for
- -- actual components of the array, not for subaggregates. Do the
- -- check on a copy, because the expression may be shared among
- -- several choices, some of which might be non-null.
-
- if Present (Etype (N))
- and then Is_Array_Type (Etype (N))
- and then No (Next_Index (Index))
- then
- Expander_Mode_Save_And_Set (False);
- Tcopy := New_Copy_Tree (Expr);
- Set_Parent (Tcopy, N);
- Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
- Expander_Mode_Restore;
+ -- Ada0Y (AI-287): Nothing else need to be done in case of
+ -- default initialized component
+
+ if not Present (Expr) then
+ null;
+
+ else
+ -- The expression must be type-checked even though no component
+ -- of the aggregate will have this value. This is done only for
+ -- actual components of the array, not for subaggregates. Do
+ -- the check on a copy, because the expression may be shared
+ -- among several choices, some of which might be non-null.
+
+ if Present (Etype (N))
+ and then Is_Array_Type (Etype (N))
+ and then No (Next_Index (Index))
+ then
+ Expander_Mode_Save_And_Set (False);
+ Tcopy := New_Copy_Tree (Expr);
+ Set_Parent (Tcopy, N);
+ Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
+ Expander_Mode_Restore;
+ end if;
end if;
return S;
@@ -891,6 +950,7 @@ package body Exp_Aggr is
and then Local_Compile_Time_Known_Value (H)
and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
then
+
Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
@@ -1084,7 +1144,8 @@ package body Exp_Aggr is
Expr : Node_Id;
Typ : Entity_Id;
- Others_Expr : Node_Id := Empty;
+ Others_Expr : Node_Id := Empty;
+ Others_Mbox_Present : Boolean := False;
Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
@@ -1096,8 +1157,8 @@ package body Exp_Aggr is
Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
-- After Duplicate_Subexpr these are side-effect free.
- Low : Node_Id;
- High : Node_Id;
+ Low : Node_Id;
+ High : Node_Id;
Nb_Choices : Nat := 0;
Table : Case_Table_Type (1 .. Number_Of_Choices (N));
@@ -1144,7 +1205,12 @@ package body Exp_Aggr is
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Set_Loop_Actions (Assoc, New_List);
- Others_Expr := Expression (Assoc);
+
+ if Box_Present (Assoc) then
+ Others_Mbox_Present := True;
+ else
+ Others_Expr := Expression (Assoc);
+ end if;
exit;
end if;
@@ -1155,9 +1221,15 @@ package body Exp_Aggr is
end if;
Nb_Choices := Nb_Choices + 1;
- Table (Nb_Choices) := (Choice_Lo => Low,
- Choice_Hi => High,
- Choice_Node => Expression (Assoc));
+ if Box_Present (Assoc) then
+ Table (Nb_Choices) := (Choice_Lo => Low,
+ Choice_Hi => High,
+ Choice_Node => Empty);
+ else
+ Table (Nb_Choices) := (Choice_Lo => Low,
+ Choice_Hi => High,
+ Choice_Node => Expression (Assoc));
+ end if;
Next (Choice);
end loop;
@@ -1185,7 +1257,7 @@ package body Exp_Aggr is
-- We don't need to generate loops over empty gaps, but if there is
-- a single empty range we must analyze the expression for semantics
- if Present (Others_Expr) then
+ if Present (Others_Expr) or else Others_Mbox_Present then
declare
First : Boolean := True;
@@ -1254,12 +1326,21 @@ package body Exp_Aggr is
if Present (Component_Associations (N)) then
Assoc := Last (Component_Associations (N));
- Expr := Expression (Assoc);
- Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
- Aggr_High,
- Expr),
- To => New_Code);
+ -- Ada0Y (AI-287)
+ if Box_Present (Assoc) then
+ Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
+ Aggr_High,
+ Empty),
+ To => New_Code);
+ else
+ Expr := Expression (Assoc);
+
+ Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
+ Aggr_High,
+ Expr), -- AI-287
+ To => New_Code);
+ end if;
end if;
end if;
@@ -1544,11 +1625,19 @@ package body Exp_Aggr is
-- types and components
if (Nkind (Target) = N_Identifier
+ and then Present (Etype (Target))
and then Is_Limited_Type (Etype (Target)))
or else (Nkind (Target) = N_Selected_Component
+ and then Present (Etype (Selector_Name (Target)))
and then Is_Limited_Type (Etype (Selector_Name (Target))))
or else (Nkind (Target) = N_Unchecked_Type_Conversion
+ and then Present (Etype (Target))
and then Is_Limited_Type (Etype (Target)))
+ or else (Nkind (Target) = N_Unchecked_Expression
+ and then Nkind (Expression (Target)) = N_Indexed_Component
+ and then Present (Etype (Prefix (Expression (Target))))
+ and then Is_Limited_Type
+ (Etype (Prefix (Expression (Target)))))
then
if Init_Pr then
@@ -1666,11 +1755,22 @@ package body Exp_Aggr is
Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
Set_Assignment_OK (Ref);
- Append_List_To (Start_L,
- Build_Initialization_Call (Loc,
- Id_Ref => Ref,
- Typ => Init_Typ,
- In_Init_Proc => Within_Init_Proc));
+ if Has_Default_Init_Comps (N)
+ or else Has_Task (Base_Type (Init_Typ))
+ then
+ Append_List_To (Start_L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => Init_Typ,
+ In_Init_Proc => Within_Init_Proc,
+ With_Default_Init => True));
+ else
+ Append_List_To (Start_L,
+ Build_Initialization_Call (Loc,
+ Id_Ref => Ref,
+ Typ => Init_Typ,
+ In_Init_Proc => Within_Init_Proc));
+ end if;
if Is_Constrained (Entity (A))
and then Has_Discriminants (Entity (A))
@@ -1812,18 +1912,48 @@ package body Exp_Aggr is
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
- -- Default initialization of a limited component
+ -- Ada0Y (AI-287): Default initialization of a limited component
if Box_Present (Comp)
and then Is_Limited_Type (Etype (Selector))
then
+
+ -- Ada0Y (AI-287): If the component type has tasks then generate
+ -- the activation chain and master entities (except in case of an
+ -- allocator because in that case these entities are generated
+ -- by Build_Task_Allocate_Block_With_Init_Stmts)
+
+ declare
+ Ctype : Entity_Id := Etype (Selector);
+ Inside_Allocator : Boolean := False;
+ P : Node_Id := Parent (N);
+
+ begin
+ if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
+ while Present (P) loop
+ if Nkind (P) = N_Allocator then
+ Inside_Allocator := True;
+ exit;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ if not Inside_Init_Proc and not Inside_Allocator then
+ Build_Activation_Chain_Entity (N);
+ Build_Master_Entity (Etype (N));
+ end if;
+ end if;
+ end;
+
Append_List_To (L,
Build_Initialization_Call (Loc,
Id_Ref => Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Selector,
- Loc)),
- Typ => Etype (Selector)));
+ Loc)),
+ Typ => Etype (Selector),
+ With_Default_Init => True));
goto Next_Comp;
end if;
@@ -2200,10 +2330,26 @@ package body Exp_Aggr is
Access_Type : constant Entity_Id := Etype (Temp);
begin
- Insert_Actions_After (Decl,
- Late_Expansion (Aggr, Typ, Occ,
- Find_Final_List (Access_Type),
- Associated_Final_Chain (Base_Type (Access_Type))));
+ if Has_Default_Init_Comps (Aggr) then
+ declare
+ L : constant List_Id := New_List;
+ Init_Stmts : List_Id;
+
+ begin
+ Init_Stmts := Late_Expansion (Aggr, Typ, Occ,
+ Find_Final_List (Access_Type),
+ Associated_Final_Chain (Base_Type (Access_Type)));
+
+ Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
+ Insert_Actions_After (Decl, L);
+ end;
+
+ else
+ Insert_Actions_After (Decl,
+ Late_Expansion (Aggr, Typ, Occ,
+ Find_Final_List (Access_Type),
+ Associated_Final_Chain (Base_Type (Access_Type))));
+ end if;
end Convert_Aggr_In_Allocator;
--------------------------------
@@ -2706,6 +2852,14 @@ package body Exp_Aggr is
-- Start of processing for Convert_To_Positional
begin
+ -- Ada0Y (AI-287): Do not convert in case of default initialized
+ -- components because in this case will need to call the corresponding
+ -- IP procedure.
+
+ if Has_Default_Init_Comps (N) then
+ return;
+ end if;
+
if Is_Flat (N, Number_Dimensions (Typ)) then
return;
end if;
@@ -3827,14 +3981,19 @@ package body Exp_Aggr is
(N, Sec_Stack => Has_Controlled_Component (Typ));
end if;
- Maybe_In_Place_OK :=
- Comes_From_Source (N)
- and then Nkind (Parent (N)) = N_Assignment_Statement
- and then not Is_Bit_Packed_Array (Typ)
- and then not Has_Controlled_Component (Typ)
- and then In_Place_Assign_OK;
+ if Has_Default_Init_Comps (N) then
+ Maybe_In_Place_OK := False;
+ else
+ Maybe_In_Place_OK :=
+ Comes_From_Source (N)
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then not Is_Bit_Packed_Array (Typ)
+ and then not Has_Controlled_Component (Typ)
+ and then In_Place_Assign_OK;
+ end if;
- if Comes_From_Source (Parent (N))
+ if not Has_Default_Init_Comps (N)
+ and then Comes_From_Source (Parent (N))
and then Nkind (Parent (N)) = N_Object_Declaration
and then not Must_Slide (N, Typ)
and then N = Expression (Parent (N))
@@ -3938,6 +4097,15 @@ package body Exp_Aggr is
Target := New_Reference_To (Tmp, Loc);
else
+
+ if Has_Default_Init_Comps (N) then
+
+ -- Ada0Y (AI-287): This case has not been analyzed???
+
+ pragma Assert (False);
+ null;
+ end if;
+
-- Name in assignment is explicit dereference.
Target := New_Copy (Tmp);
@@ -3945,6 +4113,7 @@ package body Exp_Aggr is
Aggr_Code :=
Build_Array_Aggr_Code (N,
+ Ctype => Ctyp,
Index => First_Index (Typ),
Into => Target,
Scalar_Comp => Is_Scalar_Type (Ctyp));
@@ -4478,14 +4647,17 @@ package body Exp_Aggr is
function Has_Default_Init_Comps (N : Node_Id) return Boolean is
Comps : constant List_Id := Component_Associations (N);
C : Node_Id;
-
+ Expr : Node_Id;
begin
pragma Assert (Nkind (N) = N_Aggregate
- or else Nkind (N) = N_Extension_Aggregate);
+ or else Nkind (N) = N_Extension_Aggregate);
+
if No (Comps) then
return False;
end if;
+ -- Check if any direct component has default initialized components
+
C := First (Comps);
while Present (C) loop
if Box_Present (C) then
@@ -4494,6 +4666,24 @@ package body Exp_Aggr is
Next (C);
end loop;
+
+ -- Recursive call in case of aggregate expression
+
+ C := First (Comps);
+ while Present (C) loop
+ Expr := Expression (C);
+
+ if Present (Expr)
+ and then (Nkind (Expr) = N_Aggregate
+ or else Nkind (Expr) = N_Extension_Aggregate)
+ and then Has_Default_Init_Comps (Expr)
+ then
+ return True;
+ end if;
+
+ Next (C);
+ end loop;
+
return False;
end Has_Default_Init_Comps;
@@ -4527,20 +4717,23 @@ package body Exp_Aggr is
Typ : Entity_Id;
Target : Node_Id;
Flist : Node_Id := Empty;
- Obj : Entity_Id := Empty) return List_Id
- is
+ Obj : Entity_Id := Empty) return List_Id is
begin
if Is_Record_Type (Etype (N)) then
return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
- else
+ elsif Is_Array_Type (Etype (N)) then
return
Build_Array_Aggr_Code
- (N,
- First_Index (Typ),
- Target,
- Is_Scalar_Type (Component_Type (Typ)),
- No_List,
- Flist);
+ (N => N,
+ Ctype => Component_Type (Etype (N)),
+ Index => First_Index (Typ),
+ Into => Target,
+ Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
+ Indices => No_List,
+ Flist => Flist);
+ else
+ pragma Assert (False);
+ return New_List;
end if;
end Late_Expansion;
Index: exp_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.adb,v
retrieving revision 1.10
diff -u -p -r1.10 exp_ch3.adb
--- exp_ch3.adb 27 Oct 2003 14:27:17 -0000 1.10
+++ exp_ch3.adb 8 Dec 2003 10:31:50 -0000
@@ -56,6 +56,7 @@ with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
+with Stringt; use Stringt;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@@ -1032,13 +1033,14 @@ package body Exp_Ch3 is
-- end;
function Build_Initialization_Call
- (Loc : Source_Ptr;
- Id_Ref : Node_Id;
- Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
- Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List)
- return List_Id
+ (Loc : Source_Ptr;
+ Id_Ref : Node_Id;
+ Typ : Entity_Id;
+ In_Init_Proc : Boolean := False;
+ Enclos_Type : Entity_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False)
+ return List_Id
is
First_Arg : Node_Id;
Args : List_Id;
@@ -1076,7 +1078,6 @@ package body Exp_Ch3 is
-- honest. Actually it isn't quite type honest, because there can be
-- conflicts of views in the private type case. That is why we set
-- Conversion_OK in the conversion node.
-
if (Is_Record_Type (Typ)
or else Is_Array_Type (Typ)
or else Is_Private_Type (Typ))
@@ -1110,12 +1111,28 @@ package body Exp_Ch3 is
Append_To (Args, Make_Identifier (Loc, Name_uChain));
- Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
- Decl := Last (Decls);
+ -- Ada0Y (AI-287): In case of default initialized components
+ -- with tasks, we generate a null string actual parameter.
+ -- This is just a workaround that must be improved later???
- Append_To (Args,
- New_Occurrence_Of (Defining_Identifier (Decl), Loc));
- Append_List (Decls, Res);
+ if With_Default_Init then
+ declare
+ S : String_Id;
+ Null_String : Node_Id;
+ begin
+ Start_String;
+ S := End_String;
+ Null_String := Make_String_Literal (Loc, Strval => S);
+ Append_To (Args, Null_String);
+ end;
+ else
+ Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type);
+ Decl := Last (Decls);
+
+ Append_To (Args,
+ New_Occurrence_Of (Defining_Identifier (Decl), Loc));
+ Append_List (Decls, Res);
+ end if;
else
Decls := No_List;
@@ -1202,7 +1219,22 @@ package body Exp_Ch3 is
end if;
end if;
- Append_To (Args, Arg);
+ -- Ada0Y (AI-287) In case of default initialized components, we
+ -- need to generate the corresponding selected component node
+ -- to access the discriminant value. In other cases this is not
+ -- required because we are inside the init proc and we use the
+ -- corresponding formal.
+
+ if With_Default_Init
+ and then Nkind (Id_Ref) = N_Selected_Component
+ then
+ Append_To (Args,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Prefix (Id_Ref)),
+ Selector_Name => Arg));
+ else
+ Append_To (Args, Arg);
+ end if;
Next_Discriminant (Discr);
end loop;
Index: exp_ch3.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch3.ads,v
retrieving revision 1.6
diff -u -p -r1.6 exp_ch3.ads
--- exp_ch3.ads 21 Oct 2003 13:41:59 -0000 1.6
+++ exp_ch3.ads 8 Dec 2003 10:31:50 -0000
@@ -52,13 +52,14 @@ package Exp_Ch3 is
-- and the discriminant checking functions are inserted after this node.
function Build_Initialization_Call
- (Loc : Source_Ptr;
- Id_Ref : Node_Id;
- Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
- Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List)
- return List_Id;
+ (Loc : Source_Ptr;
+ Id_Ref : Node_Id;
+ Typ : Entity_Id;
+ In_Init_Proc : Boolean := False;
+ Enclos_Type : Entity_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False)
+ return List_Id;
-- Builds a call to the initialization procedure of the Id entity. Id_Ref
-- is either a new reference to Id (for record fields), or an indexed
-- component (for array elements). Loc is the source location for the
@@ -76,6 +77,10 @@ package Exp_Ch3 is
-- entry families bounded by discriminants, protected type discriminants
-- can appear within expressions in array bounds (not as stand-alone
-- identifiers) and a general replacement is necessary.
+ --
+ -- Ada0Y (AI-287): With_Default_Init is used to indicate that the initia-
+ -- lization call corresponds to a default initialized component of an
+ -- aggregate.
procedure Freeze_Type (N : Node_Id);
-- This procedure executes the freezing actions associated with the given
Index: exp_ch9.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.adb,v
retrieving revision 1.8
diff -u -p -r1.8 exp_ch9.adb
--- exp_ch9.adb 21 Oct 2003 13:41:59 -0000 1.8
+++ exp_ch9.adb 8 Dec 2003 10:31:51 -0000
@@ -69,8 +69,7 @@ package body Exp_Ch9 is
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
- Tsk : Entity_Id)
- return Node_Id;
+ Tsk : Entity_Id) return Node_Id;
-- Compute the index position for an entry call. Tsk is the target
-- task. If the bounds of some entry family depend on discriminants,
-- the expression computed by this function uses the discriminants
@@ -79,8 +78,7 @@ package body Exp_Ch9 is
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
- Prot : Entity_Id)
- return List_Id;
+ Prot : Entity_Id) return List_Id;
-- For an entry family and its barrier function, we define a local entity
-- that maps the index in the call into the entry index into the object:
--
@@ -105,23 +103,20 @@ package body Exp_Ch9 is
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id;
+ Pid : Node_Id) return Node_Id;
-- Build the function body returning the value of the barrier expression
-- for the specified entry body.
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Build a specification for a function implementing
-- the protected entry barrier of the specified entry body.
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Node_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Common to tasks and protected types. Copy discriminant specifications,
-- build record declaration. N is the type declaration, Ctyp is the
-- concurrent entity (task type or protected type).
@@ -129,40 +124,33 @@ package body Exp_Ch9 is
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Compute number of entries for concurrent object. This is a count of
-- simple entries, followed by an expression that computes the length
-- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type.
- function Build_Find_Body_Index
- (Typ : Entity_Id)
- return Node_Id;
+ function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
-- Entry_Bodies_Array, to determine the body and barrier function used
-- in a protected entry call. A pointer to this function appears in every
-- protected object.
- function Build_Find_Body_Index_Spec
- (Typ : Entity_Id)
- return Node_Id;
- -- Build subprogram declaration for previous one.
+ function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
+ -- Build subprogram declaration for previous one
function Build_Protected_Entry
- (N : Node_Id;
- Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id;
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Pid : Node_Id) return Node_Id;
-- Build the procedure implementing the statement sequence of
-- the specified entry body.
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id;
+ Loc : Source_Ptr) return Node_Id;
-- Build a specification for a procedure implementing
-- the statement sequence of the specified entry body.
-- Add attributes associating it with the entry defining identifier
@@ -171,8 +159,7 @@ package body Exp_Ch9 is
function Build_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
- N_Op_Spec : Node_Id)
- return Node_Id;
+ N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the protected version of a protected
-- subprogram. Its statement sequence first defers abortion, then locks
-- the associated protected object, and then enters a block that contains
@@ -185,8 +172,7 @@ package body Exp_Ch9 is
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
- Ident : Entity_Id)
- return List_Id;
+ Ident : Entity_Id) return List_Id;
-- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_
-- Subprogram_Type. Builds signature of protected subprogram, adding the
-- formal that corresponds to the object itself. For an access to protected
@@ -197,8 +183,7 @@ package body Exp_Ch9 is
function Build_Selected_Name
(Prefix, Selector : Name_Id;
- Append_Char : Character := ' ')
- return Name_Id;
+ Append_Char : Character := ' ') return Name_Id;
-- Build a name in the form of Prefix__Selector, with an optional
-- character appended. This is used for internal subprograms generated
-- for operations of protected types, including barrier functions. In
@@ -227,9 +212,8 @@ package body Exp_Ch9 is
-- value type that is associated with the task type.
function Build_Unprotected_Subprogram_Body
- (N : Node_Id;
- Pid : Node_Id)
- return Node_Id;
+ (N : Node_Id;
+ Pid : Node_Id) return Node_Id;
-- This routine constructs the unprotected version of a protected
-- subprogram body, which is contains all of the code in the
-- original, unexpanded body. This is the version of the protected
@@ -248,8 +232,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id;
+ Ttyp : Entity_Id) return Node_Id;
-- Compute (Hi - Lo) for two entry family indices. Hi is the index in
-- an accept statement, or the upper bound in the discrete subtype of
-- an entry declaration. Lo is the corresponding lower bound. Ttyp is
@@ -259,8 +242,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id;
+ Ttyp : Entity_Id) return Node_Id;
-- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in
-- a family, and handle properly the superflat case. This is equivalent
-- to the use of 'Length on the index type, but must use Family_Offset
@@ -275,9 +257,8 @@ package body Exp_Ch9 is
-- the entry name, and the entry family index.
function Find_Task_Or_Protected_Pragma
- (T : Node_Id;
- P : Name_Id)
- return Node_Id;
+ (T : Node_Id;
+ P : Name_Id) return Node_Id;
-- Searches the task or protected definition T for the first occurrence
-- of the pragma whose name is given by P. The caller has ensured that
-- the pragma is present in the task definition. A special case is that
@@ -302,8 +283,7 @@ package body Exp_Ch9 is
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
- Tsk : Entity_Id)
- return Node_Id
+ Tsk : Entity_Id) return Node_Id
is
Ttyp : constant Entity_Id := Etype (Tsk);
Expr : Node_Id;
@@ -746,8 +726,7 @@ package body Exp_Ch9 is
function Build_Barrier_Function
(N : Node_Id;
Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id
+ Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
@@ -816,8 +795,7 @@ package body Exp_Ch9 is
function Build_Barrier_Function_Specification
(Def_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
begin
return Make_Function_Specification (Loc,
@@ -841,9 +819,8 @@ package body Exp_Ch9 is
--------------------------
function Build_Call_With_Task
- (N : Node_Id;
- E : Entity_Id)
- return Node_Id
+ (N : Node_Id;
+ E : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
@@ -861,8 +838,7 @@ package body Exp_Ch9 is
function Build_Corresponding_Record
(N : Node_Id;
Ctyp : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Rec_Ent : constant Entity_Id :=
Make_Defining_Identifier
@@ -941,8 +917,7 @@ package body Exp_Ch9 is
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
Eindx : Nat;
Ent : Entity_Id;
@@ -999,10 +974,7 @@ package body Exp_Ch9 is
-- Build_Find_Body_Index --
---------------------------
- function Build_Find_Body_Index
- (Typ : Entity_Id)
- return Node_Id
- is
+ function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Ent : Entity_Id;
E_Typ : Entity_Id;
@@ -1192,10 +1164,7 @@ package body Exp_Ch9 is
-- Build_Find_Body_Index_Spec --
--------------------------------
- function Build_Find_Body_Index_Spec
- (Typ : Entity_Id)
- return Node_Id
- is
+ function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
@@ -1285,10 +1254,9 @@ package body Exp_Ch9 is
---------------------------
function Build_Protected_Entry
- (N : Node_Id;
- Ent : Entity_Id;
- Pid : Node_Id)
- return Node_Id
+ (N : Node_Id;
+ Ent : Entity_Id;
+ Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Decls : constant List_Id := New_List;
@@ -1401,8 +1369,7 @@ package body Exp_Ch9 is
function Build_Protected_Entry_Specification
(Def_Id : Entity_Id;
Ent_Id : Entity_Id;
- Loc : Source_Ptr)
- return Node_Id
+ Loc : Source_Ptr) return Node_Id
is
P : Entity_Id;
@@ -1440,8 +1407,7 @@ package body Exp_Ch9 is
(N : Node_Id;
Obj_Type : Entity_Id;
Unprotected : Boolean := False;
- Ident : Entity_Id)
- return List_Id
+ Ident : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Formal : Entity_Id;
@@ -1494,8 +1460,7 @@ package body Exp_Ch9 is
function Build_Protected_Sub_Specification
(N : Node_Id;
Prottyp : Entity_Id;
- Unprotected : Boolean := False)
- return Node_Id
+ Unprotected : Boolean := False) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
@@ -1556,8 +1521,7 @@ package body Exp_Ch9 is
function Build_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
- N_Op_Spec : Node_Id)
- return Node_Id
+ N_Op_Spec : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : Node_Id;
@@ -1573,9 +1537,8 @@ package body Exp_Ch9 is
Service_Name : Node_Id;
Service_Stmt : Node_Id;
R : Node_Id;
- Return_Stmt : Node_Id := Empty;
- Pre_Stmts : List_Id := No_List;
- -- Initializations to avoid spurious warnings from GCC3.
+ Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
+ Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
Stmts : List_Id;
Object_Parm : Node_Id;
Exc_Safe : Boolean;
@@ -1906,7 +1869,6 @@ package body Exp_Ch9 is
then
Add_Shared_Var_Lock_Procs (N);
end if;
-
end Build_Protected_Subprogram_Call;
-------------------------
@@ -1915,8 +1877,7 @@ package body Exp_Ch9 is
function Build_Selected_Name
(Prefix, Selector : Name_Id;
- Append_Char : Character := ' ')
- return Name_Id
+ Append_Char : Character := ' ') return Name_Id
is
Select_Buffer : String (1 .. Hostparm.Max_Name_Length);
Select_Len : Natural;
@@ -2336,7 +2297,6 @@ package body Exp_Ch9 is
Analyze (N);
end;
-
end Build_Simple_Entry_Call;
--------------------------------
@@ -2352,7 +2312,7 @@ package body Exp_Ch9 is
begin
-- Get the activation chain entity. Except in the case of a package
- -- body, this is in the node that was passed. For a package body, we
+ -- body, this is in the node that w as passed. For a package body, we
-- have to find the corresponding package declaration node.
if Nkind (N) = N_Package_Body then
@@ -2424,7 +2384,6 @@ package body Exp_Ch9 is
Analyze (Call);
Check_Task_Activation (N);
end if;
-
end Build_Task_Activation_Call;
-------------------------------
@@ -2492,9 +2451,63 @@ package body Exp_Ch9 is
Append_To (Actions, Block);
Set_Activation_Chain_Entity (Block, Chain);
-
end Build_Task_Allocate_Block;
+ -----------------------------------------------
+ -- Build_Task_Allocate_Block_With_Init_Stmts --
+ -----------------------------------------------
+
+ procedure Build_Task_Allocate_Block_With_Init_Stmts
+ (Actions : List_Id;
+ N : Node_Id;
+ Init_Stmts : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Chain : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_uChain);
+ Blkent : Entity_Id;
+ Block : Node_Id;
+
+ begin
+ Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+
+ Append_To (Init_Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Chain, Loc),
+ Attribute_Name => Name_Unchecked_Access))));
+
+ Block :=
+ Make_Block_Statement (Loc,
+ Identifier => New_Reference_To (Blkent, Loc),
+ Declarations => New_List (
+
+ -- _Chain : Activation_Chain;
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Chain,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Activation_Chain), Loc))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts),
+
+ Has_Created_Identifier => True,
+ Is_Task_Allocation_Block => True);
+
+ Append_To (Actions,
+ Make_Implicit_Label_Declaration (Loc,
+ Defining_Identifier => Blkent,
+ Label_Construct => Block));
+
+ Append_To (Actions, Block);
+
+ Set_Activation_Chain_Entity (Block, Chain);
+ end Build_Task_Allocate_Block_With_Init_Stmts;
+
-----------------------------------
-- Build_Task_Proc_Specification --
-----------------------------------
@@ -2531,7 +2544,6 @@ package body Exp_Ch9 is
Subtype_Mark =>
New_Reference_To
(Corresponding_Record_Type (T), Loc)))));
-
end Build_Task_Proc_Specification;
---------------------------------------
@@ -2539,9 +2551,8 @@ package body Exp_Ch9 is
---------------------------------------
function Build_Unprotected_Subprogram_Body
- (N : Node_Id;
- Pid : Node_Id)
- return Node_Id
+ (N : Node_Id;
+ Pid : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
N_Op_Spec : Node_Id;
@@ -2563,7 +2574,6 @@ package body Exp_Ch9 is
Declarations => Op_Decls,
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N));
-
end Build_Unprotected_Subprogram_Body;
----------------------------
@@ -2800,9 +2810,8 @@ package body Exp_Ch9 is
------------------------
function Convert_Concurrent
- (N : Node_Id;
- Typ : Entity_Id)
- return Node_Id
+ (N : Node_Id;
+ Typ : Entity_Id) return Node_Id
is
begin
if not Is_Concurrent_Type (Typ) then
@@ -2822,8 +2831,7 @@ package body Exp_Ch9 is
(Sloc : Source_Ptr;
Ent : Entity_Id;
Index : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id
+ Ttyp : Entity_Id) return Node_Id
is
Expr : Node_Id;
Num : Node_Id;
@@ -4550,7 +4558,6 @@ package body Exp_Ch9 is
Set_Privals (Dec, Next_Op, Loc);
Set_Discriminals (Dec);
end if;
-
end Expand_N_Entry_Body;
-----------------------------------
@@ -6049,7 +6056,6 @@ package body Exp_Ch9 is
Make_Aggregate (Loc, Expressions => New_List (Null_Body, Expr)));
Num_Accept := Num_Accept + 1;
-
end Add_Accept;
----------------------------
@@ -7716,8 +7722,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id
+ Ttyp : Entity_Id) return Node_Id
is
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If one of the bounds is a reference to a discriminant, replace
@@ -7790,8 +7795,7 @@ package body Exp_Ch9 is
(Loc : Source_Ptr;
Hi : Node_Id;
Lo : Node_Id;
- Ttyp : Entity_Id)
- return Node_Id
+ Ttyp : Entity_Id) return Node_Id
is
Ityp : Entity_Id;
@@ -7820,9 +7824,8 @@ package body Exp_Ch9 is
-----------------------------------
function Find_Task_Or_Protected_Pragma
- (T : Node_Id;
- P : Name_Id)
- return Node_Id
+ (T : Node_Id;
+ P : Name_Id) return Node_Id
is
N : Node_Id;
@@ -7898,8 +7901,7 @@ package body Exp_Ch9 is
function Index_Constant_Declaration
(N : Node_Id;
Index_Id : Entity_Id;
- Prot : Entity_Id)
- return List_Id
+ Prot : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Decls : constant List_Id := New_List;
@@ -8003,8 +8005,7 @@ package body Exp_Ch9 is
--------------------------------
function Make_Initialize_Protection
- (Protect_Rec : Entity_Id)
- return List_Id
+ (Protect_Rec : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Protect_Rec);
P_Arr : Entity_Id;
Index: exp_ch9.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/exp_ch9.ads,v
retrieving revision 1.5
diff -u -p -r1.5 exp_ch9.ads
--- exp_ch9.ads 24 Apr 2003 17:54:00 -0000 1.5
+++ exp_ch9.ads 8 Dec 2003 10:31:51 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -163,6 +163,15 @@ package Exp_Ch9 is
-- for the initialization call, constructed by the caller, which uses
-- the Master_Id of the access type as the _Master parameter, and _Chain
-- (defined above) as the _Chain parameter.
+
+ procedure Build_Task_Allocate_Block_With_Init_Stmts
+ (Actions : List_Id;
+ N : Node_Id;
+ Init_Stmts : List_Id);
+ -- Ada0Y (AI-287): Similar to previous routine, but used to expand alloca-
+ -- ted aggregates with default initialized components. Init_Stmts contains
+ -- the list of statements required to initialize the allocated aggregate.
+ -- It replaces the call to Init (Args) done by Build_Task_Allocate_Block.
function Concurrent_Ref (N : Node_Id) return Node_Id;
-- Given the name of a concurrent object (task or protected object), or
Index: gnatbind.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/gnatbind.adb,v
retrieving revision 1.7
diff -u -p -r1.7 gnatbind.adb
--- gnatbind.adb 21 Oct 2003 13:42:05 -0000 1.7
+++ gnatbind.adb 8 Dec 2003 10:31:51 -0000
@@ -471,7 +471,7 @@ begin
-- Add System.Standard_Library to list to ensure that these files are
-- included in the bind, even if not directly referenced from Ada code
- -- This is suppressed if the configurable run-time requests it.
+ -- This is suppressed if the appropriate targparm switch is set.
if not Suppress_Standard_Library_On_Target then
Name_Buffer (1 .. 12) := "s-stalib.ali";
Index: lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/lib.ads,v
retrieving revision 1.8
diff -u -p -r1.8 lib.ads
--- lib.ads 24 Nov 2003 14:27:57 -0000 1.8
+++ lib.ads 8 Dec 2003 10:31:51 -0000
@@ -587,7 +587,7 @@ package Lib is
-- function returns True if the given generic unit entity E is for a
-- generic unit that should be separately compiled, and false otherwise.
--
- -- Now GNAT can compile any generic unit including predefifined ones, but
+ -- Now GNAT can compile any generic unit including predefined ones, but
-- because of the backward compatibility (to keep the ability to use old
-- compiler versions to build GNAT) compiling library generics is an
-- option. That is, now GNAT compiles a library generic as an ordinary
Index: par-ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/par-ch4.adb,v
retrieving revision 1.9
diff -u -p -r1.9 par-ch4.adb
--- par-ch4.adb 20 Nov 2003 09:54:00 -0000 1.9
+++ par-ch4.adb 8 Dec 2003 10:31:51 -0000
@@ -1167,6 +1167,20 @@ package body Ch4 is
end if;
end if;
+ -- Ada0Y (AI-287): The box notation is allowed only with named
+ -- notation because positional notation might be error prone. For
+ -- example, in "(X, <>, Y, <>)", there is no type associated with
+ -- the boxes, so you might not be leaving out the components you
+ -- thought you were leaving out.
+
+ if Extensions_Allowed and then Token = Tok_Box then
+ Error_Msg_SC ("(Ada 0Y) box notation only allowed with "
+ & "named notation");
+ Scan; -- past BOX
+ Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
+ return Aggregate_Node;
+ end if;
+
Expr_Node := P_Expression_Or_Range_Attribute;
-- Extension aggregate case
@@ -1390,9 +1404,13 @@ package body Ch4 is
TF_Arrow;
if Token = Tok_Box then
+
+ -- Ada0Y (AI-287): The box notation is used to indicate the default
+ -- initialization of limited aggregate components
+
if not Extensions_Allowed then
Error_Msg_SP
- ("Limited aggregates are an Ada0X extension");
+ ("(Ada 0Y) limited aggregates are an Ada0X extension");
if OpenVMS then
Error_Msg_SP
Index: prj.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.adb,v
retrieving revision 1.13
diff -u -p -r1.13 prj.adb
--- prj.adb 20 Nov 2003 09:54:00 -0000 1.13
+++ prj.adb 8 Dec 2003 10:31:51 -0000
@@ -123,7 +123,8 @@ package body Prj is
Seen => False,
Flag1 => False,
Flag2 => False,
- Depth => 0);
+ Depth => 0,
+ Unkept_Comments => False);
-------------------
-- Add_To_Buffer --
@@ -386,15 +387,6 @@ package body Prj is
and then Left.Current_Body_Suffix = Right.Current_Body_Suffix
and then Left.Separate_Suffix = Right.Separate_Suffix;
end Same_Naming_Scheme;
-
- ----------
- -- Scan --
- ----------
-
- procedure Scan is
- begin
- Scanner.Scan;
- end Scan;
--------------------------
-- Standard_Naming_Data --
Index: prj.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj.ads,v
retrieving revision 1.15
diff -u -p -r1.15 prj.ads
--- prj.ads 20 Nov 2003 09:54:00 -0000 1.15
+++ prj.ads 8 Dec 2003 10:31:51 -0000
@@ -554,6 +554,10 @@ package Prj is
-- The maximum depth of a project in the project graph.
-- Depth of main project is 0.
+ Unkept_Comments : Boolean := False;
+ -- True if there are comments in the project sources that cannot
+ -- be kept in the project tree.
+
end record;
function Empty_Project return Project_Data;
@@ -609,10 +613,6 @@ package Prj is
-- imports B, directly or indirectly, Action will be called for A before
-- it is called for B. With_State may be used by Action to choose a
-- behavior or to report some global result.
-
- procedure Scan;
- pragma Inline (Scan);
- -- Scan a token. Change all operator symbols to literal strings.
private
Index: prj-dect.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-dect.adb,v
retrieving revision 1.8
diff -u -p -r1.8 prj-dect.adb
--- prj-dect.adb 21 Oct 2003 13:42:12 -0000 1.8
+++ prj-dect.adb 8 Dec 2003 10:31:51 -0000
@@ -125,6 +125,7 @@ package body Prj.Dect is
begin
Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
Set_Location_Of (Attribute, To => Token_Ptr);
+ Set_Previous_Line_Node (Attribute);
-- Scan past "for"
@@ -467,6 +468,9 @@ package body Prj.Dect is
if Current_Attribute = Empty_Attribute then
Attribute := Empty_Node;
end if;
+
+ Set_End_Of_Line (Attribute);
+ Set_Previous_Line_Node (Attribute);
end Parse_Attribute_Declaration;
-----------------------------
@@ -535,6 +539,9 @@ package body Prj.Dect is
Expect (Tok_Is, "IS");
if Token = Tok_Is then
+ Set_End_Of_Line (Case_Construction);
+ Set_Previous_Line_Node (Case_Construction);
+ Set_Next_End_Node (Case_Construction);
-- Scan past "is"
@@ -571,6 +578,8 @@ package body Prj.Dect is
Scan;
Expect (Tok_Arrow, "`=>`");
+ Set_End_Of_Line (Current_Item);
+ Set_Previous_Line_Node (Current_Item);
-- Empty_Node in Field1 of a Case_Item indicates
-- the "when others =>" branch.
@@ -596,6 +605,8 @@ package body Prj.Dect is
Set_First_Choice_Of (Current_Item, To => First_Choice);
Expect (Tok_Arrow, "`=>`");
+ Set_End_Of_Line (Current_Item);
+ Set_Previous_Line_Node (Current_Item);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
@@ -613,6 +624,7 @@ package body Prj.Dect is
End_Case_Construction;
Expect (Tok_End, "`END CASE`");
+ Remove_Next_End_Node;
if Token = Tok_End then
@@ -629,6 +641,7 @@ package body Prj.Dect is
Scan;
Expect (Tok_Semicolon, "`;`");
+ Set_Previous_End_Node (Case_Construction);
end Parse_Case_Construction;
@@ -673,6 +686,9 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package);
+ Set_End_Of_Line (Current_Declaration);
+ Set_Previous_Line_Node (Current_Declaration);
+
when Tok_For =>
Parse_Attribute_Declaration
@@ -681,6 +697,9 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package);
+ Set_End_Of_Line (Current_Declaration);
+ Set_Previous_Line_Node (Current_Declaration);
+
when Tok_Package =>
-- Package declaration
@@ -693,6 +712,8 @@ package body Prj.Dect is
(Package_Declaration => Current_Declaration,
Current_Project => Current_Project);
+ Set_Previous_End_Node (Current_Declaration);
+
when Tok_Type =>
-- Type String Declaration
@@ -706,6 +727,9 @@ package body Prj.Dect is
(String_Type => Current_Declaration,
Current_Project => Current_Project);
+ Set_End_Of_Line (Current_Declaration);
+ Set_Previous_Line_Node (Current_Declaration);
+
when Tok_Case =>
-- Case construction
@@ -716,6 +740,8 @@ package body Prj.Dect is
Current_Project => Current_Project,
Current_Package => Current_Package);
+ Set_Previous_End_Node (Current_Declaration);
+
when others =>
exit;
@@ -928,8 +954,13 @@ package body Prj.Dect is
end if;
Expect (Tok_Semicolon, "`;`");
+ Set_End_Of_Line (Package_Declaration);
+ Set_Previous_Line_Node (Package_Declaration);
elsif Token = Tok_Is then
+ Set_End_Of_Line (Package_Declaration);
+ Set_Previous_Line_Node (Package_Declaration);
+ Set_Next_End_Node (Package_Declaration);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
@@ -970,6 +1001,7 @@ package body Prj.Dect is
end if;
Expect (Tok_Semicolon, "`;`");
+ Remove_Next_End_Node;
else
Error_Msg ("expected IS or RENAMES", Token_Ptr);
Index: prj-part.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.adb,v
retrieving revision 1.9
diff -u -p -r1.9 prj-part.adb
--- prj-part.adb 10 Nov 2003 17:29:59 -0000 1.9
+++ prj-part.adb 8 Dec 2003 10:31:51 -0000
@@ -81,6 +81,7 @@ package body Prj.Part is
Path : Name_Id;
Location : Source_Ptr;
Limited_With : Boolean;
+ Node : Project_Node_Id;
Next : With_Id;
end record;
-- Information about an imported project, to be put in table Withs below
@@ -426,7 +427,8 @@ package body Prj.Part is
(Project : out Project_Node_Id;
Project_File_Name : String;
Always_Errout_Finalize : Boolean;
- Packages_To_Check : String_List_Access := All_Packages)
+ Packages_To_Check : String_List_Access := All_Packages;
+ Store_Comments : Boolean := False)
is
Current_Directory : constant String := Get_Current_Dir;
@@ -451,6 +453,8 @@ package body Prj.Part is
begin
Prj.Err.Initialize;
+ Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
+ Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
-- Parse the main project file
@@ -578,6 +582,8 @@ package body Prj.Part is
Current_With : With_Record;
+ Current_With_Node : Project_Node_Id := Empty_Node;
+
begin
-- Assume no context clause
@@ -588,6 +594,7 @@ package body Prj.Part is
-- or we have exhausted the with clauses.
while Token = Tok_With or else Token = Tok_Limited loop
+ Current_With_Node := Default_Project_Node (Of_Kind => N_With_Clause);
Limited_With := Token = Tok_Limited;
if Limited_With then
@@ -612,6 +619,7 @@ package body Prj.Part is
(Path => Token_Name,
Location => Token_Ptr,
Limited_With => Limited_With,
+ Node => Current_With_Node,
Next => No_With);
Withs.Increment_Last;
@@ -629,6 +637,8 @@ package body Prj.Part is
Scan;
if Token = Tok_Semicolon then
+ Set_End_Of_Line (Current_With_Node);
+ Set_Previous_Line_Node (Current_With_Node);
-- End of (possibly multiple) with clause;
@@ -639,6 +649,9 @@ package body Prj.Part is
Error_Msg ("expected comma or semi colon", Token_Ptr);
exit Comma_Loop;
end if;
+
+ Current_With_Node :=
+ Default_Project_Node (Of_Kind => N_With_Clause);
end loop Comma_Loop;
end loop With_Loop;
end Pre_Parse_Context_Clause;
@@ -714,13 +727,11 @@ package body Prj.Part is
-- First with clause of the context clause
- Current_Project := Default_Project_Node
- (Of_Kind => N_With_Clause);
+ Current_Project := Current_With.Node;
Imported_Projects := Current_Project;
else
- Next_Project := Default_Project_Node
- (Of_Kind => N_With_Clause);
+ Next_Project := Current_With.Node;
Set_Next_With_Clause_Of (Current_Project, Next_Project);
Current_Project := Next_Project;
end if;
@@ -829,6 +840,8 @@ package body Prj.Part is
use Tree_Private_Part;
+ Project_Comment_State : Tree.Comment_State;
+
begin
declare
Normed : String := Normalize_Pathname (Path_Name);
@@ -868,6 +881,8 @@ package body Prj.Part is
end if;
end loop;
+ -- Put the new path name on the stack
+
Project_Stack.Increment_Last;
Project_Stack.Table (Project_Stack.Last).Name := Canonical_Path_Name;
@@ -933,6 +948,7 @@ package body Prj.Part is
Save_Project_Scan_State (Project_Scan_State);
Source_Index := Load_Project_File (Path_Name);
+ Tree.Save (Project_Comment_State);
-- if we cannot find it, we stop
@@ -943,6 +959,7 @@ package body Prj.Part is
end if;
Prj.Err.Scanner.Initialize_Scanner (Types.No_Unit, Source_Index);
+ Tree.Reset_State;
Scan;
if Name_From_Path = No_Name then
@@ -962,6 +979,10 @@ package body Prj.Part is
Write_Eol;
end if;
+ -- Is there any imported project?
+
+ Pre_Parse_Context_Clause (First_With);
+
Project_Directory := Immediate_Directory_Of (Normed_Path_Name);
Project := Default_Project_Node (Of_Kind => N_Project);
Project_Stack.Table (Project_Stack.Last).Id := Project;
@@ -969,10 +990,6 @@ package body Prj.Part is
Set_Path_Name_Of (Project, Normed_Path_Name);
Set_Location_Of (Project, Token_Ptr);
- -- Is there any imported project?
-
- Pre_Parse_Context_Clause (First_With);
-
Expect (Tok_Project, "PROJECT");
-- Mark location of PROJECT token if present
@@ -1276,6 +1293,9 @@ package body Prj.Part is
end if;
Expect (Tok_Is, "IS");
+ Set_End_Of_Line (Project);
+ Set_Previous_Line_Node (Project);
+ Set_Next_End_Node (Project);
declare
Project_Declaration : Project_Node_Id := Empty_Node;
@@ -1296,6 +1316,7 @@ package body Prj.Part is
end;
Expect (Tok_End, "END");
+ Remove_Next_End_Node;
-- Skip "end" if present
@@ -1353,6 +1374,7 @@ package body Prj.Part is
-- source.
if Token = Tok_Semicolon then
+ Set_Previous_End_Node (Project);
Scan;
if Token /= Tok_EOF then
@@ -1368,6 +1390,15 @@ package body Prj.Part is
-- And remove the project from the project stack
Project_Stack.Decrement_Last;
+
+ -- Indicate if there are unkept comments
+
+ Tree.Set_Project_File_Includes_Unkept_Comments
+ (Node => Project, To => Tree.There_Are_Unkept_Comments);
+
+ -- And restore the comment state that was saved
+
+ Tree.Restore (Project_Comment_State);
end Parse_Single_Project;
-----------------------
Index: prj-part.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-part.ads,v
retrieving revision 1.5
diff -u -p -r1.5 prj-part.ads
--- prj-part.ads 21 Oct 2003 13:42:12 -0000 1.5
+++ prj-part.ads 8 Dec 2003 10:31:51 -0000
@@ -34,13 +34,15 @@ package Prj.Part is
(Project : out Project_Node_Id;
Project_File_Name : String;
Always_Errout_Finalize : Boolean;
- Packages_To_Check : String_List_Access := All_Packages);
+ Packages_To_Check : String_List_Access := All_Packages;
+ Store_Comments : Boolean := False);
-- Parse project file and all its imported project files and create a tree.
-- Return the node for the project (or Empty_Node if parsing failed). If
-- Always_Errout_Finalize is True, Errout.Finalize is called in all cases,
-- Otherwise, Errout.Finalize is only called if there are errors (but not
-- if there are only warnings). Packages_To_Check indicates the packages
-- where any unknown attribute produces an error. For other packages, an
- -- unknown attribute produces a warning.
+ -- unknown attribute produces a warning. When Store_Comments is True,
+ -- comments are stored in the parse tree.
end Prj.Part;
Index: prj-pp.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-pp.adb,v
retrieving revision 1.6
diff -u -p -r1.6 prj-pp.adb
--- prj-pp.adb 21 Oct 2003 13:42:12 -0000 1.6
+++ prj-pp.adb 8 Dec 2003 10:31:51 -0000
@@ -27,8 +27,8 @@
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Hostparm;
-with Namet; use Namet;
-with Output; use Output;
+with Namet; use Namet;
+with Output; use Output;
with Snames;
package body Prj.PP is
@@ -47,7 +47,6 @@ package body Prj.PP is
procedure Indicate_Tested (Kind : Project_Node_Kind);
-- Set the corresponding component of array Not_Tested to False.
-- Only called by pragmas Debug.
- --
---------------------
-- Indicate_Tested --
@@ -98,9 +97,13 @@ package body Prj.PP is
procedure Write_Line (S : String);
-- Outputs S followed by a new line
- procedure Write_String (S : String);
+ procedure Write_String (S : String; Truncated : Boolean := False);
-- Outputs S using Write_Str, starting a new line if line would
- -- become too long.
+ -- become too long, when Truncated = False.
+ -- When Truncated = True, only the part of the string that can fit on
+ -- the line is output.
+
+ procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
Write_Char : Write_Char_Ap := Output.Write_Char'Access;
Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
@@ -246,6 +249,21 @@ package body Prj.PP is
end if;
end Write_Empty_Line;
+ -------------------------------
+ -- Write_End_Of_Line_Comment --
+ -------------------------------
+
+ procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
+ Value : Name_Id := End_Of_Line_Comment (Node);
+ begin
+ if Value /= No_Name then
+ Write_String (" --");
+ Write_String (Get_Name_String (Value), Truncated => True);
+ end if;
+
+ Write_Line ("");
+ end Write_End_Of_Line_Comment;
+
----------------
-- Write_Line --
----------------
@@ -262,18 +280,24 @@ package body Prj.PP is
-- Write_String --
------------------
- procedure Write_String (S : String) is
+ procedure Write_String (S : String; Truncated : Boolean := False) is
+ Length : Natural := S'Length;
begin
-- If the string would not fit on the line,
-- start a new line.
- if Column + S'Length > Max_Line_Length then
- Write_Eol.all;
- Column := 0;
+ if Column + Length > Max_Line_Length then
+ if Truncated then
+ Length := Max_Line_Length - Column;
+
+ else
+ Write_Eol.all;
+ Column := 0;
+ end if;
end if;
- Write_Str (S);
- Column := Column + S'Length;
+ Write_Str (S (S'First .. S'First + Length - 1));
+ Column := Column + Length;
end Write_String;
-----------
@@ -296,6 +320,7 @@ package body Prj.PP is
Write_Empty_Line (Always => True);
end if;
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("project ");
Output_Name (Name_Of (Node));
@@ -307,21 +332,26 @@ package body Prj.PP is
Output_String (Extended_Project_Path_Of (Node));
end if;
- Write_Line (" is");
+ Write_String (" is");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
Write_Empty_Line (Always => True);
-- Output all of the declarations in the project
Print (Project_Declaration_Of (Node), Indent);
+ Print (First_Comment_Before_End (Node), Indent + Increment);
Start_Line (Indent);
Write_String ("end ");
Output_Name (Name_Of (Node));
Write_Line (";");
+ Print (First_Comment_After_End (Node), Indent);
when N_With_Clause =>
pragma Debug (Indicate_Tested (N_With_Clause));
if Name_Of (Node) /= No_Name then
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
if Non_Limited_Project_Node_Of (Node) = Empty_Node then
@@ -330,7 +360,9 @@ package body Prj.PP is
Write_String ("with ");
Output_String (String_Value_Of (Node));
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
end if;
Print (Next_With_Clause_Of (Node), Indent);
@@ -352,6 +384,7 @@ package body Prj.PP is
when N_Package_Declaration =>
pragma Debug (Indicate_Tested (N_Package_Declaration));
Write_Empty_Line (Always => True);
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("package ");
Output_Name (Name_Of (Node));
@@ -362,10 +395,14 @@ package body Prj.PP is
(Name_Of (Project_Of_Renamed_Package_Of (Node)));
Write_String (".");
Output_Name (Name_Of (Node));
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After_End (Node), Indent);
else
- Write_Line (" is");
+ Write_String (" is");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
if First_Declarative_Item_Of (Node) /= Empty_Node then
Print
@@ -373,15 +410,19 @@ package body Prj.PP is
Indent + Increment);
end if;
+ Print (First_Comment_Before_End (Node),
+ Indent + Increment);
Start_Line (Indent);
Write_String ("end ");
Output_Name (Name_Of (Node));
Write_Line (";");
+ Print (First_Comment_After_End (Node), Indent);
Write_Empty_Line;
end if;
when N_String_Type_Declaration =>
pragma Debug (Indicate_Tested (N_String_Type_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("type ");
Output_Name (Name_Of (Node));
@@ -404,7 +445,9 @@ package body Prj.PP is
end loop;
end;
- Write_Line (");");
+ Write_String (");");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Literal_String =>
pragma Debug (Indicate_Tested (N_Literal_String));
@@ -412,6 +455,7 @@ package body Prj.PP is
when N_Attribute_Declaration =>
pragma Debug (Indicate_Tested (N_Attribute_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("for ");
Output_Attribute_Name (Name_Of (Node));
@@ -424,26 +468,34 @@ package body Prj.PP is
Write_String (" use ");
Print (Expression_Of (Node), Indent);
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Typed_Variable_Declaration =>
pragma Debug
(Indicate_Tested (N_Typed_Variable_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Output_Name (Name_Of (Node));
Write_String (" : ");
Output_Name (Name_Of (String_Type_Of (Node)));
Write_String (" := ");
Print (Expression_Of (Node), Indent);
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Variable_Declaration =>
pragma Debug (Indicate_Tested (N_Variable_Declaration));
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Output_Name (Name_Of (Node));
Write_String (" := ");
Print (Expression_Of (Node), Indent);
- Write_Line (";");
+ Write_String (";");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent);
when N_Expression =>
pragma Debug (Indicate_Tested (N_Expression));
@@ -566,10 +618,13 @@ package body Prj.PP is
if Is_Non_Empty then
Write_Empty_Line;
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("case ");
Print (Case_Variable_Reference_Of (Node), Indent);
- Write_Line (" is");
+ Write_String (" is");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
declare
Case_Item : Project_Node_Id :=
@@ -584,8 +639,11 @@ package body Prj.PP is
end loop;
end;
+ Print (First_Comment_Before_End (Node),
+ Indent + Increment);
Start_Line (Indent);
Write_Line ("end case;");
+ Print (First_Comment_After_End (Node), Indent);
end if;
end;
@@ -596,6 +654,7 @@ package body Prj.PP is
or else not Eliminate_Empty_Case_Constructions
then
Write_Empty_Line;
+ Print (First_Comment_Before (Node), Indent);
Start_Line (Indent);
Write_String ("when ");
@@ -618,7 +677,9 @@ package body Prj.PP is
end;
end if;
- Write_Line (" =>");
+ Write_String (" =>");
+ Write_End_Of_Line_Comment (Node);
+ Print (First_Comment_After (Node), Indent + Increment);
declare
First : constant Project_Node_Id :=
@@ -626,13 +687,39 @@ package body Prj.PP is
begin
if First = Empty_Node then
- Write_Eol.all;
+ Write_Empty_Line;
else
Print (First, Indent + Increment);
end if;
end;
end if;
+
+ when N_Comment_Zones =>
+
+ -- Nothing to do, because it will not be processed directly
+
+ null;
+
+ when N_Comment =>
+ pragma Debug (Indicate_Tested (N_Comment));
+
+ if Follows_Empty_Line (Node) then
+ Write_Empty_Line;
+ end if;
+
+ Start_Line (Indent);
+ Write_String ("--");
+ Write_String
+ (Get_Name_String (String_Value_Of (Node)),
+ Truncated => True);
+ Write_Line ("");
+
+ if Is_Followed_By_Empty_Line (Node) then
+ Write_Empty_Line;
+ end if;
+
+ Print (Next_Comment (Node), Indent);
end case;
end if;
end Print;
@@ -674,7 +761,7 @@ package body Prj.PP is
Output.Write_Line ("Project_Node_Kinds not tested:");
for Kind in Project_Node_Kind loop
- if Not_Tested (Kind) then
+ if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
Output.Write_Str (" ");
Output.Write_Line (Project_Node_Kind'Image (Kind));
end if;
Index: prj-tree.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.adb,v
retrieving revision 1.8
diff -u -p -r1.8 prj-tree.adb
--- prj-tree.adb 10 Nov 2003 17:29:59 -0000 1.8
+++ prj-tree.adb 8 Dec 2003 10:31:51 -0000
@@ -24,17 +24,193 @@
-- --
------------------------------------------------------------------------------
+with Prj.Err;
+
package body Prj.Tree is
+ Node_With_Comments : constant array (Project_Node_Kind) of Boolean :=
+ (N_Project => True,
+ N_With_Clause => True,
+ N_Project_Declaration => False,
+ N_Declarative_Item => False,
+ N_Package_Declaration => True,
+ N_String_Type_Declaration => True,
+ N_Literal_String => False,
+ N_Attribute_Declaration => True,
+ N_Typed_Variable_Declaration => True,
+ N_Variable_Declaration => True,
+ N_Expression => False,
+ N_Term => False,
+ N_Literal_String_List => False,
+ N_Variable_Reference => False,
+ N_External_Value => False,
+ N_Attribute_Reference => False,
+ N_Case_Construction => True,
+ N_Case_Item => True,
+ N_Comment_Zones => True,
+ N_Comment => True);
+ -- Indicates the kinds of node that may have associated comments
+
+ package Next_End_Nodes is new Table.Table
+ (Table_Component_Type => Project_Node_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Next_End_Nodes");
+ -- A stack of nodes to indicates to what node the next "end" is associated
+
use Tree_Private_Part;
+ End_Of_Line_Node : Project_Node_Id := Empty_Node;
+ -- The node an end of line comment may be associated with
+
+ Previous_Line_Node : Project_Node_Id := Empty_Node;
+ -- The node an immediately following comment may be associated with
+
+ Previous_End_Node : Project_Node_Id := Empty_Node;
+ -- The node comments immediately following an "end" line may be
+ -- associated with.
+
+ Unkept_Comments : Boolean := False;
+ -- Set to True when some comments may not be associated with any node
+
+ function Comment_Zones_Of
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Returns the ID of the N_Comment_Zones node associated with node Node.
+ -- If there is not already an N_Comment_Zones node, create one and
+ -- associate it with node Node.
+
+ ------------------
+ -- Add_Comments --
+ ------------------
+
+ procedure Add_Comments (To : Project_Node_Id; Where : Comment_Location) is
+ Zone : Project_Node_Id := Empty_Node;
+ Previous : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert
+ (To /= Empty_Node
+ and then
+ Project_Nodes.Table (To).Kind /= N_Comment);
+
+ Zone := Project_Nodes.Table (To).Comments;
+
+ if Zone = Empty_Node then
+
+ -- Create new N_Comment_Zones node
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment_Zones,
+ Expr_Kind => Undefined,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+
+ Zone := Project_Nodes.Last;
+ Project_Nodes.Table (To).Comments := Zone;
+ end if;
+
+ if Where = End_Of_Line then
+ Project_Nodes.Table (Zone).Value := Comments.Table (1).Value;
+
+ else
+ -- Get each comments in the Comments table and link them to node To
+
+ for J in 1 .. Comments.Last loop
+
+ -- Create new N_Comment node
+
+ if (Where = After or else Where = After_End) and then
+ Token /= Tok_EOF and then
+ Comments.Table (J).Follows_Empty_Line
+ then
+ Comments.Table (1 .. Comments.Last - J + 1) :=
+ Comments.Table (J .. Comments.Last);
+ Comments.Set_Last (Comments.Last - J + 1);
+ return;
+ end if;
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment,
+ Expr_Kind => Undefined,
+ Flag1 => Comments.Table (J).Follows_Empty_Line,
+ Flag2 =>
+ Comments.Table (J).Is_Followed_By_Empty_Line,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => Comments.Table (J).Value,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Comments => Empty_Node);
+
+ -- If this is the first comment, put it in the right field of
+ -- the node Zone.
+
+ if Previous = Empty_Node then
+ case Where is
+ when Before =>
+ Project_Nodes.Table (Zone).Field1 := Project_Nodes.Last;
+
+ when After =>
+ Project_Nodes.Table (Zone).Field2 := Project_Nodes.Last;
+
+ when Before_End =>
+ Project_Nodes.Table (Zone).Field3 := Project_Nodes.Last;
+
+ when After_End =>
+ Project_Nodes.Table (Zone).Comments := Project_Nodes.Last;
+
+ when End_Of_Line =>
+ null;
+ end case;
+
+ else
+ -- When it is not the first, link it to the previous one
+
+ Project_Nodes.Table (Previous).Comments := Project_Nodes.Last;
+ end if;
+
+ -- This node becomes the previous one for the next comment, if
+ -- there is one.
+
+ Previous := Project_Nodes.Last;
+ end loop;
+ end if;
+
+ -- Empty the Comments table, so that there is no risk to link the same
+ -- comments to another node.
+
+ Comments.Set_Last (0);
+ end Add_Comments;
+
+
--------------------------------
-- Associative_Array_Index_Of --
--------------------------------
function Associative_Array_Index_Of
- (Node : Project_Node_Id)
- return Name_Id
+ (Node : Project_Node_Id) return Name_Id
is
begin
pragma Assert
@@ -51,8 +227,7 @@ package body Prj.Tree is
----------------------------
function Associative_Package_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -67,8 +242,7 @@ package body Prj.Tree is
----------------------------
function Associative_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -90,7 +264,7 @@ package body Prj.Tree is
(Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- return Project_Nodes.Table (Node).Case_Insensitive;
+ return Project_Nodes.Table (Node).Flag1;
end Case_Insensitive;
--------------------------------
@@ -98,8 +272,7 @@ package body Prj.Tree is
--------------------------------
function Case_Variable_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -109,13 +282,54 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end Case_Variable_Reference_Of;
+ ----------------------
+ -- Comment_Zones_Of --
+ ----------------------
+
+ function Comment_Zones_Of
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ -- If there is not already an N_Comment_Zones associated, create a new
+ -- one and associate it with node Node.
+
+ if Zone = Empty_Node then
+ Project_Nodes.Increment_Last;
+ Zone := Project_Nodes.Last;
+ Project_Nodes.Table (Zone) :=
+ (Kind => N_Comment_Zones,
+ Location => No_Location,
+ Directory => No_Name,
+ Expr_Kind => Undefined,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+ Project_Nodes.Table (Node).Comments := Zone;
+ end if;
+
+ return Zone;
+ end Comment_Zones_Of;
+
-----------------------
-- Current_Item_Node --
-----------------------
function Current_Item_Node
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -130,8 +344,7 @@ package body Prj.Tree is
------------------
function Current_Term
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -147,28 +360,118 @@ package body Prj.Tree is
function Default_Project_Node
(Of_Kind : Project_Node_Kind;
- And_Expr_Kind : Variable_Kind := Undefined)
- return Project_Node_Id
+ And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id
is
+ Result : Project_Node_Id;
+ Zone : Project_Node_Id;
+ Previous : Project_Node_Id;
+
begin
+ -- Create new node with specified kind and expression kind
+
Project_Nodes.Increment_Last;
Project_Nodes.Table (Project_Nodes.Last) :=
- (Kind => Of_Kind,
- Location => No_Location,
- Directory => No_Name,
- Expr_Kind => And_Expr_Kind,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Path_Name => No_Name,
- Value => No_Name,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Case_Insensitive => False,
- Extending_All => False);
- return Project_Nodes.Last;
+ (Kind => Of_Kind,
+ Location => No_Location,
+ Directory => No_Name,
+ Expr_Kind => And_Expr_Kind,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+
+ -- Save the new node for the returned value
+
+ Result := Project_Nodes.Last;
+
+ if Comments.Last > 0 then
+
+ -- If this is not a node with comments, then set the flag
+
+ if not Node_With_Comments (Of_Kind) then
+ Unkept_Comments := True;
+
+ elsif Of_Kind /= N_Comment and then Of_Kind /= N_Comment_Zones then
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment_Zones,
+ Expr_Kind => Undefined,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => No_Name,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Flag1 => False,
+ Flag2 => False,
+ Comments => Empty_Node);
+
+ Zone := Project_Nodes.Last;
+ Project_Nodes.Table (Result).Comments := Zone;
+ Previous := Empty_Node;
+
+ for J in 1 .. Comments.Last loop
+
+ -- Create a new N_Comment node
+
+ Project_Nodes.Increment_Last;
+ Project_Nodes.Table (Project_Nodes.Last) :=
+ (Kind => N_Comment,
+ Expr_Kind => Undefined,
+ Flag1 => Comments.Table (J).Follows_Empty_Line,
+ Flag2 =>
+ Comments.Table (J).Is_Followed_By_Empty_Line,
+ Location => No_Location,
+ Directory => No_Name,
+ Variables => Empty_Node,
+ Packages => Empty_Node,
+ Pkg_Id => Empty_Package,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Value => Comments.Table (J).Value,
+ Field1 => Empty_Node,
+ Field2 => Empty_Node,
+ Field3 => Empty_Node,
+ Comments => Empty_Node);
+
+ -- Link it to the N_Comment_Zones node, if it is the first,
+ -- otherwise to the previous one.
+
+ if Previous = Empty_Node then
+ Project_Nodes.Table (Zone).Field1 := Project_Nodes.Last;
+
+ else
+ Project_Nodes.Table (Previous).Comments :=
+ Project_Nodes.Last;
+ end if;
+
+ -- This new node will be the previous one for the next
+ -- N_Comment node, if there is one.
+
+ Previous := Project_Nodes.Last;
+ end loop;
+
+ -- Empty the Comments table after all comments have been processed
+
+ Comments.Set_Last (0);
+ end if;
+ end if;
+
+ return Result;
end Default_Project_Node;
------------------
@@ -184,6 +487,24 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Directory;
end Directory_Of;
+ -------------------------
+ -- End_Of_Line_Comment --
+ -------------------------
+
+ function End_Of_Line_Comment (Node : Project_Node_Id) return Name_Id is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return No_Name;
+ else
+ return Project_Nodes.Table (Zone).Value;
+ end if;
+ end End_Of_Line_Comment;
+
------------------------
-- Expression_Kind_Of --
------------------------
@@ -219,8 +540,7 @@ package body Prj.Tree is
-------------------
function Expression_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -240,8 +560,7 @@ package body Prj.Tree is
-------------------------
function Extended_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -256,8 +575,7 @@ package body Prj.Tree is
------------------------------
function Extended_Project_Path_Of
- (Node : Project_Node_Id)
- return Name_Id
+ (Node : Project_Node_Id) return Name_Id
is
begin
pragma Assert
@@ -271,8 +589,7 @@ package body Prj.Tree is
-- Extending_Project_Of --
--------------------------
function Extending_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -287,8 +604,7 @@ package body Prj.Tree is
---------------------------
function External_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -319,8 +635,7 @@ package body Prj.Tree is
------------------------
function First_Case_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -346,13 +661,96 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end First_Choice_Of;
+ -------------------------
+ -- First_Comment_After --
+ -------------------------
+
+ function First_Comment_After
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Field2;
+ end if;
+ end First_Comment_After;
+
+ -----------------------------
+ -- First_Comment_After_End --
+ -----------------------------
+
+ function First_Comment_After_End
+ (Node : Project_Node_Id)
+ return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Comments;
+ end if;
+ end First_Comment_After_End;
+
+ --------------------------
+ -- First_Comment_Before --
+ --------------------------
+
+ function First_Comment_Before
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Field1;
+ end if;
+ end First_Comment_Before;
+
+ ------------------------------
+ -- First_Comment_Before_End --
+ ------------------------------
+
+ function First_Comment_Before_End
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
+ Zone : Project_Node_Id := Empty_Node;
+
+ begin
+ pragma Assert (Node /= Empty_Node);
+ Zone := Project_Nodes.Table (Node).Comments;
+
+ if Zone = Empty_Node then
+ return Empty_Node;
+
+ else
+ return Project_Nodes.Table (Zone).Field3;
+ end if;
+ end First_Comment_Before_End;
+
-------------------------------
-- First_Declarative_Item_Of --
-------------------------------
function First_Declarative_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -376,8 +774,7 @@ package body Prj.Tree is
------------------------------
function First_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -392,8 +789,7 @@ package body Prj.Tree is
--------------------------
function First_Literal_String
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -408,8 +804,7 @@ package body Prj.Tree is
----------------------
function First_Package_Of
- (Node : Project_Node_Id)
- return Package_Declaration_Id
+ (Node : Project_Node_Id) return Package_Declaration_Id
is
begin
pragma Assert
@@ -424,8 +819,7 @@ package body Prj.Tree is
--------------------------
function First_String_Type_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -440,8 +834,7 @@ package body Prj.Tree is
----------------
function First_Term
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -456,8 +849,7 @@ package body Prj.Tree is
-----------------------
function First_Variable_Of
- (Node : Project_Node_Id)
- return Variable_Node_Id
+ (Node : Project_Node_Id) return Variable_Node_Id
is
begin
pragma Assert
@@ -475,8 +867,7 @@ package body Prj.Tree is
--------------------------
function First_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -486,18 +877,18 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end First_With_Clause_Of;
- ----------------------
- -- Is_Extending_All --
- ----------------------
+ ------------------------
+ -- Follows_Empty_Line --
+ ------------------------
- function Is_Extending_All (Node : Project_Node_Id) return Boolean is
+ function Follows_Empty_Line (Node : Project_Node_Id) return Boolean is
begin
pragma Assert
(Node /= Empty_Node
- and then
- Project_Nodes.Table (Node).Kind = N_Project);
- return Project_Nodes.Table (Node).Extending_All;
- end Is_Extending_All;
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ return Project_Nodes.Table (Node).Flag1;
+ end Follows_Empty_Line;
----------
-- Hash --
@@ -508,14 +899,51 @@ package body Prj.Tree is
return Header_Num (N mod Project_Node_Id (Header_Num'Last));
end Hash;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Project_Nodes.Set_Last (Empty_Node);
+ Projects_Htable.Reset;
+ end Initialize;
+
+ -------------------------------
+ -- Is_Followed_By_Empty_Line --
+ -------------------------------
+
+ function Is_Followed_By_Empty_Line
+ (Node : Project_Node_Id) return Boolean
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ return Project_Nodes.Table (Node).Flag2;
+ end Is_Followed_By_Empty_Line;
+
+ ----------------------
+ -- Is_Extending_All --
+ ----------------------
+
+ function Is_Extending_All (Node : Project_Node_Id) return Boolean is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project);
+ return Project_Nodes.Table (Node).Flag2;
+ end Is_Extending_All;
+
-------------------------------------
-- Imported_Or_Extended_Project_Of --
-------------------------------------
function Imported_Or_Extended_Project_Of
(Project : Project_Node_Id;
- With_Name : Name_Id)
- return Project_Node_Id
+ With_Name : Name_Id) return Project_Node_Id
is
With_Clause : Project_Node_Id := First_With_Clause_Of (Project);
Result : Project_Node_Id := Empty_Node;
@@ -548,16 +976,6 @@ package body Prj.Tree is
return Result;
end Imported_Or_Extended_Project_Of;
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- Project_Nodes.Set_Last (Empty_Node);
- Projects_Htable.Reset;
- end Initialize;
-
-------------
-- Kind_Of --
-------------
@@ -593,8 +1011,7 @@ package body Prj.Tree is
--------------------
function Next_Case_Item
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -604,13 +1021,25 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field3;
end Next_Case_Item;
+ ------------------
+ -- Next_Comment --
+ ------------------
+
+ function Next_Comment (Node : Project_Node_Id) return Project_Node_Id is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ return Project_Nodes.Table (Node).Comments;
+ end Next_Comment;
+
---------------------------
-- Next_Declarative_Item --
---------------------------
function Next_Declarative_Item
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -625,8 +1054,7 @@ package body Prj.Tree is
-----------------------------
function Next_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -657,8 +1085,7 @@ package body Prj.Tree is
-----------------------------
function Next_Package_In_Project
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -689,8 +1116,7 @@ package body Prj.Tree is
---------------
function Next_Term
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -724,8 +1150,7 @@ package body Prj.Tree is
-------------------------
function Next_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -740,8 +1165,7 @@ package body Prj.Tree is
---------------------------------
function Non_Limited_Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -750,6 +1174,7 @@ package body Prj.Tree is
(Project_Nodes.Table (Node).Kind = N_With_Clause));
return Project_Nodes.Table (Node).Field3;
end Non_Limited_Project_Node_Of;
+
-------------------
-- Package_Id_Of --
-------------------
@@ -768,8 +1193,7 @@ package body Prj.Tree is
---------------------
function Package_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -801,8 +1225,7 @@ package body Prj.Tree is
----------------------------
function Project_Declaration_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -812,13 +1235,25 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field2;
end Project_Declaration_Of;
+ -------------------------------------------
+ -- Project_File_Includes_Unkept_Comments --
+ -------------------------------------------
+
+ function Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id) return Boolean
+ is
+ Declaration : constant Project_Node_Id :=
+ Project_Declaration_Of (Node);
+ begin
+ return Project_Nodes.Table (Declaration).Flag1;
+ end Project_File_Includes_Unkept_Comments;
+
---------------------
-- Project_Node_Of --
---------------------
function Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -837,8 +1272,7 @@ package body Prj.Tree is
-----------------------------------
function Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
+ (Node : Project_Node_Id) return Project_Node_Id
is
begin
pragma Assert
@@ -848,6 +1282,181 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end Project_Of_Renamed_Package_Of;
+ --------------------------
+ -- Remove_Next_End_Node --
+ --------------------------
+
+ procedure Remove_Next_End_Node is
+ begin
+ Next_End_Nodes.Decrement_Last;
+ end Remove_Next_End_Node;
+
+ -----------------
+ -- Reset_State --
+ -----------------
+
+ procedure Reset_State is
+ begin
+ End_Of_Line_Node := Empty_Node;
+ Previous_Line_Node := Empty_Node;
+ Previous_End_Node := Empty_Node;
+ Unkept_Comments := False;
+ Comments.Set_Last (0);
+ end Reset_State;
+
+ -------------
+ -- Restore --
+ -------------
+
+ procedure Restore (S : in Comment_State) is
+ begin
+ End_Of_Line_Node := S.End_Of_Line_Node;
+ Previous_Line_Node := S.Previous_Line_Node;
+ Previous_End_Node := S.Previous_End_Node;
+ Next_End_Nodes.Set_Last (0);
+ Unkept_Comments := S.Unkept_Comments;
+
+ Comments.Set_Last (0);
+
+ for J in S.Comments'Range loop
+ Comments.Increment_Last;
+ Comments.Table (Comments.Last) := S.Comments (J);
+ end loop;
+ end Restore;
+
+ ----------
+ -- Save --
+ ----------
+
+ procedure Save (S : out Comment_State) is
+ Cmts : Comments_Ptr := new Comment_Array (1 .. Comments.Last);
+ begin
+ for J in 1 .. Comments.Last loop
+ Cmts (J) := Comments.Table (J);
+ end loop;
+
+ S :=
+ (End_Of_Line_Node => End_Of_Line_Node,
+ Previous_Line_Node => Previous_Line_Node,
+ Previous_End_Node => Previous_End_Node,
+ Unkept_Comments => Unkept_Comments,
+ Comments => Cmts);
+ end Save;
+
+ ----------
+ -- Scan --
+ ----------
+
+ procedure Scan is
+ Empty_Line : Boolean := False;
+ begin
+ -- If there are comments, then they will not be kept. Set the flag and
+ -- clear the comments.
+
+ if Comments.Last > 0 then
+ Unkept_Comments := True;
+ Comments.Set_Last (0);
+ end if;
+
+ -- Loop until a token other that End_Of_Line or Comment is found
+
+ loop
+ Prj.Err.Scanner.Scan;
+
+ case Token is
+ when Tok_End_Of_Line =>
+ if Prev_Token = Tok_End_Of_Line then
+ Empty_Line := True;
+
+ if Comments.Last > 0 then
+ Comments.Table (Comments.Last).Is_Followed_By_Empty_Line
+ := True;
+ end if;
+ end if;
+
+ when Tok_Comment =>
+ -- If this is a line comment, add it to the comment table
+
+ if Prev_Token = Tok_End_Of_Line
+ or else Prev_Token = No_Token
+ then
+ Comments.Increment_Last;
+ Comments.Table (Comments.Last) :=
+ (Value => Comment_Id,
+ Follows_Empty_Line => Empty_Line,
+ Is_Followed_By_Empty_Line => False);
+
+ -- Otherwise, it is an end of line comment. If there is
+ -- an end of line node specified, associate the comment with
+ -- this node.
+
+ elsif End_Of_Line_Node /= Empty_Node then
+ declare
+ Zones : constant Project_Node_Id :=
+ Comment_Zones_Of (End_Of_Line_Node);
+ begin
+ Project_Nodes.Table (Zones).Value := Comment_Id;
+ end;
+
+ -- Otherwise, this end of line node cannot be kept
+
+ else
+ Unkept_Comments := True;
+ Comments.Set_Last (0);
+ end if;
+
+ Empty_Line := False;
+
+ when others =>
+ -- If there are comments, where the first comment is not
+ -- following an empty line, put the initial uninterrupted
+ -- comment zone with the node of the preceding line (either
+ -- a Previous_Line or a Previous_End node), if any.
+
+ if Comments.Last > 0 and then
+ not Comments.Table (1).Follows_Empty_Line then
+ if Previous_Line_Node /= Empty_Node then
+ Add_Comments
+ (To => Previous_Line_Node, Where => After);
+
+ elsif Previous_End_Node /= Empty_Node then
+ Add_Comments
+ (To => Previous_End_Node, Where => After_End);
+ end if;
+ end if;
+
+ -- If there are still comments and the token is "end", then
+ -- put these comments with the Next_End node, if any;
+ -- otherwise, these comments cannot be kept. Always clear
+ -- the comments.
+
+ if Comments.Last > 0 and then Token = Tok_End then
+ if Next_End_Nodes.Last > 0 then
+ Add_Comments
+ (To => Next_End_Nodes.Table (Next_End_Nodes.Last),
+ Where => Before_End);
+
+ else
+ Unkept_Comments := True;
+ end if;
+
+ Comments.Set_Last (0);
+ end if;
+
+ -- Reset the End_Of_Line, Previous_Line and Previous_End nodes
+ -- so that they are not used again.
+
+ End_Of_Line_Node := Empty_Node;
+ Previous_Line_Node := Empty_Node;
+ Previous_End_Node := Empty_Node;
+
+ -- And return
+
+ exit;
+ end case;
+ end loop;
+ end Scan;
+
------------------------------------
-- Set_Associative_Array_Index_Of --
------------------------------------
@@ -913,7 +1522,7 @@ package body Prj.Tree is
(Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
or else
Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- Project_Nodes.Table (Node).Case_Insensitive := To;
+ Project_Nodes.Table (Node).Flag1 := To;
end Set_Case_Insensitive;
------------------------------------
@@ -980,6 +1589,15 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Directory := To;
end Set_Directory_Of;
+ ---------------------
+ -- Set_End_Of_Line --
+ ---------------------
+
+ procedure Set_End_Of_Line (To : Project_Node_Id) is
+ begin
+ End_Of_Line_Node := To;
+ end Set_End_Of_Line;
+
----------------------------
-- Set_Expression_Kind_Of --
----------------------------
@@ -1096,6 +1714,63 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field1 := To;
end Set_First_Choice_Of;
+ -----------------------------
+ -- Set_First_Comment_After --
+ -----------------------------
+
+ procedure Set_First_Comment_After
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Field2 := To;
+ end Set_First_Comment_After;
+
+ ---------------------------------
+ -- Set_First_Comment_After_End --
+ ---------------------------------
+
+ procedure Set_First_Comment_After_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Comments := To;
+ end Set_First_Comment_After_End;
+
+ ------------------------------
+ -- Set_First_Comment_Before --
+ ------------------------------
+
+ procedure Set_First_Comment_Before
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Field1 := To;
+ end Set_First_Comment_Before;
+
+ ----------------------------------
+ -- Set_First_Comment_Before_End --
+ ----------------------------------
+
+ procedure Set_First_Comment_Before_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ Zone : constant Project_Node_Id :=
+ Comment_Zones_Of (Node);
+ begin
+ Project_Nodes.Table (Zone).Field2 := To;
+ end Set_First_Comment_Before_End;
+
------------------------
-- Set_Next_Case_Item --
------------------------
@@ -1112,6 +1787,22 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field3 := To;
end Set_Next_Case_Item;
+ ----------------------
+ -- Set_Next_Comment --
+ ----------------------
+
+ procedure Set_Next_Comment
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Comment);
+ Project_Nodes.Table (Node).Comments := To;
+ end Set_Next_Comment;
+
-----------------------------------
-- Set_First_Declarative_Item_Of --
-----------------------------------
@@ -1261,7 +1952,7 @@ package body Prj.Tree is
(Node /= Empty_Node
and then
Project_Nodes.Table (Node).Kind = N_Project);
- Project_Nodes.Table (Node).Extending_All := True;
+ Project_Nodes.Table (Node).Flag2 := True;
end Set_Is_Extending_All;
-----------------
@@ -1367,6 +2058,16 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field2 := To;
end Set_Next_Declarative_Item;
+ -----------------------
+ -- Set_Next_End_Node --
+ -----------------------
+
+ procedure Set_Next_End_Node (To : Project_Node_Id) is
+ begin
+ Next_End_Nodes.Increment_Last;
+ Next_End_Nodes.Table (Next_End_Nodes.Last) := To;
+ end Set_Next_End_Node;
+
---------------------------------
-- Set_Next_Expression_In_List --
---------------------------------
@@ -1533,6 +2234,23 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Path_Name := To;
end Set_Path_Name_Of;
+ ---------------------------
+ -- Set_Previous_End_Node --
+ ---------------------------
+ procedure Set_Previous_End_Node (To : Project_Node_Id) is
+ begin
+ Previous_End_Node := To;
+ end Set_Previous_End_Node;
+
+ ----------------------------
+ -- Set_Previous_Line_Node --
+ ----------------------------
+
+ procedure Set_Previous_Line_Node (To : Project_Node_Id) is
+ begin
+ Previous_Line_Node := To;
+ end Set_Previous_Line_Node;
+
--------------------------------
-- Set_Project_Declaration_Of --
--------------------------------
@@ -1549,6 +2267,20 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Field2 := To;
end Set_Project_Declaration_Of;
+ -----------------------------------------------
+ -- Set_Project_File_Includes_Unkept_Comments --
+ -----------------------------------------------
+
+ procedure Set_Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id;
+ To : Boolean)
+ is
+ Declaration : constant Project_Node_Id :=
+ Project_Declaration_Of (Node);
+ begin
+ Project_Nodes.Table (Declaration).Flag1 := To;
+ end Set_Project_File_Includes_Unkept_Comments;
+
-------------------------
-- Set_Project_Node_Of --
-------------------------
@@ -1631,6 +2363,8 @@ package body Prj.Tree is
and then
(Project_Nodes.Table (Node).Kind = N_With_Clause
or else
+ Project_Nodes.Table (Node).Kind = N_Comment
+ or else
Project_Nodes.Table (Node).Kind = N_Literal_String));
Project_Nodes.Table (Node).Value := To;
end Set_String_Value_Of;
@@ -1639,8 +2373,9 @@ package body Prj.Tree is
-- String_Type_Of --
--------------------
- function String_Type_Of (Node : Project_Node_Id)
- return Project_Node_Id is
+ function String_Type_Of
+ (Node : Project_Node_Id) return Project_Node_Id
+ is
begin
pragma Assert
(Node /= Empty_Node
@@ -1667,6 +2402,8 @@ package body Prj.Tree is
and then
(Project_Nodes.Table (Node).Kind = N_With_Clause
or else
+ Project_Nodes.Table (Node).Kind = N_Comment
+ or else
Project_Nodes.Table (Node).Kind = N_Literal_String));
return Project_Nodes.Table (Node).Value;
end String_Value_Of;
@@ -1677,8 +2414,7 @@ package body Prj.Tree is
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
- Value : Name_Id)
- return Boolean
+ Value : Name_Id) return Boolean
is
begin
pragma Assert
@@ -1705,5 +2441,15 @@ package body Prj.Tree is
end;
end Value_Is_Valid;
+
+ -------------------------------
+ -- There_Are_Unkept_Comments --
+ -------------------------------
+
+ function There_Are_Unkept_Comments return Boolean is
+ begin
+ return Unkept_Comments;
+ end There_Are_Unkept_Comments;
+
end Prj.Tree;
Index: prj-tree.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/prj-tree.ads,v
retrieving revision 1.10
diff -u -p -r1.10 prj-tree.ads
--- prj-tree.ads 10 Nov 2003 17:29:59 -0000 1.10
+++ prj-tree.ads 8 Dec 2003 10:31:51 -0000
@@ -30,8 +30,8 @@ with GNAT.HTable;
with Prj.Attr; use Prj.Attr;
with Prj.Com; use Prj.Com;
+with Table; use Table;
with Types; use Types;
-with Table;
package Prj.Tree is
@@ -79,7 +79,9 @@ package Prj.Tree is
N_External_Value,
N_Attribute_Reference,
N_Case_Construction,
- N_Case_Item);
+ N_Case_Item,
+ N_Comment_Zones,
+ N_Comment);
-- Each node in the tree is of a Project_Node_Kind
-- For the signification of the fields in each node of a
-- Project_Node_Kind, look at package Tree_Private_Part.
@@ -90,8 +92,7 @@ package Prj.Tree is
function Default_Project_Node
(Of_Kind : Project_Node_Kind;
- And_Expr_Kind : Variable_Kind := Undefined)
- return Project_Node_Id;
+ And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id;
-- Returns a Project_Node_Record with the specified Kind and
-- Expr_Kind; all the other components have default nil values.
@@ -100,11 +101,85 @@ package Prj.Tree is
function Imported_Or_Extended_Project_Of
(Project : Project_Node_Id;
- With_Name : Name_Id)
- return Project_Node_Id;
+ With_Name : Name_Id) return Project_Node_Id;
-- Return the node of a project imported or extended by project Project and
-- whose name is With_Name. Return Empty_Node if there is no such project.
+ --------------
+ -- Comments --
+ --------------
+
+ type Comment_State is private;
+ -- A type to store the values of several global variables related to
+ -- comments.
+
+ procedure Save (S : out Comment_State);
+ -- Save in variable S the comment state. Called before scanning a new
+ -- project file.
+
+ procedure Restore (S : in Comment_State);
+ -- Restore the comment state to a previously saved value. Called after
+ -- scanning a project file.
+
+ procedure Reset_State;
+ -- Set the comment state to its initial value. Called before scanning a
+ -- new project file.
+
+ function There_Are_Unkept_Comments return Boolean;
+ -- Indicates that some of the comments in a project file could not be
+ -- stored in the parse tree.
+
+ procedure Set_Previous_Line_Node (To : Project_Node_Id);
+ -- Indicate the node on the previous line. If there are comments
+ -- immediately following this line, then they should be associated with
+ -- this node.
+
+ procedure Set_Previous_End_Node (To : Project_Node_Id);
+ -- Indicate that on the previous line the "end" belongs to node To.
+ -- If there are comments immediately following this "end" line, they
+ -- should be associated with this node.
+
+ procedure Set_End_Of_Line (To : Project_Node_Id);
+ -- Indicate the node on the current line. If there is an end of line
+ -- comment, then it should be associated with this node.
+
+ procedure Set_Next_End_Node (To : Project_Node_Id);
+ -- Put node To on the top of the end node stack. When an "end" line
+ -- is found with this node on the top of the end node stack, the comments,
+ -- if any, immediately preceding this "end" line will be associated with
+ -- this node.
+
+ procedure Remove_Next_End_Node;
+ -- Remove the top of the end node stack.
+
+ ------------------------
+ -- Comment Processing --
+ ------------------------
+
+ type Comment_Data is record
+ Value : Name_Id := No_Name;
+ Follows_Empty_Line : Boolean := False;
+ Is_Followed_By_Empty_Line : Boolean := False;
+ end record;
+
+ package Comments is new Table.Table
+ (Table_Component_Type => Comment_Data,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Prj.Tree.Comments");
+ -- A table to store the comments that may be stored is the tree
+
+ procedure Scan;
+ -- Scan the tokens and accumulate comments.
+
+ type Comment_Location is
+ (Before, After, Before_End, After_End, End_Of_Line);
+
+ procedure Add_Comments (To : Project_Node_Id; Where : Comment_Location);
+ -- Add comments to this node.
+
----------------------
-- Access Functions --
----------------------
@@ -125,6 +200,39 @@ package Prj.Tree is
pragma Inline (Location_Of);
-- Valid for all non empty nodes
+ function First_Comment_After
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function First_Comment_After_End
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function First_Comment_Before
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function First_Comment_Before_End
+ (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment_Zones nodes
+
+ function Next_Comment (Node : Project_Node_Id) return Project_Node_Id;
+ -- Valid only for N_Comment nodes
+
+ function End_Of_Line_Comment (Node : Project_Node_Id) return Name_Id;
+ -- Valid only for non empty nodes
+
+ function Follows_Empty_Line (Node : Project_Node_Id) return Boolean;
+ -- Valid only for N_Comment nodes
+
+ function Is_Followed_By_Empty_Line (Node : Project_Node_Id) return Boolean;
+ -- Valid only for N_Comment nodes
+
+ function Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id)
+ return Boolean;
+ -- Valid only for N_Project nodes
+
function Directory_Of (Node : Project_Node_Id) return Name_Id;
pragma Inline (Directory_Of);
-- Only valid for N_Project nodes.
@@ -140,14 +248,12 @@ package Prj.Tree is
-- Only valid for N_Project
function First_Variable_Of
- (Node : Project_Node_Id)
- return Variable_Node_Id;
+ (Node : Project_Node_Id) return Variable_Node_Id;
pragma Inline (First_Variable_Of);
-- Only valid for N_Project or N_Package_Declaration nodes
function First_Package_Of
- (Node : Project_Node_Id)
- return Package_Declaration_Id;
+ (Node : Project_Node_Id) return Package_Declaration_Id;
pragma Inline (First_Package_Of);
-- Only valid for N_Project nodes
@@ -155,123 +261,105 @@ package Prj.Tree is
pragma Inline (Package_Id_Of);
-- Only valid for N_Package_Declaration nodes
- function Path_Name_Of (Node : Project_Node_Id) return Name_Id;
+ function Path_Name_Of (Node : Project_Node_Id) return Name_Id;
pragma Inline (Path_Name_Of);
-- Only valid for N_Project and N_With_Clause nodes.
- function String_Value_Of (Node : Project_Node_Id) return Name_Id;
+ function String_Value_Of (Node : Project_Node_Id) return Name_Id;
pragma Inline (String_Value_Of);
- -- Only valid for N_With_Clause or N_Literal_String nodes.
+ -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment
function First_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_With_Clause_Of);
-- Only valid for N_Project nodes
function Project_Declaration_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Project_Declaration_Of);
-- Only valid for N_Project nodes
function Extending_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Extending_Project_Of);
-- Only valid for N_Project_Declaration nodes
function First_String_Type_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_String_Type_Of);
-- Only valid for N_Project nodes
function Extended_Project_Path_Of
- (Node : Project_Node_Id)
- return Name_Id;
+ (Node : Project_Node_Id) return Name_Id;
pragma Inline (Extended_Project_Path_Of);
-- Only valid for N_With_Clause nodes
function Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Project_Node_Of);
-- Only valid for N_With_Clause, N_Variable_Reference and
-- N_Attribute_Reference nodes.
function Non_Limited_Project_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Non_Limited_Project_Node_Of);
-- Only valid for N_With_Clause nodes. Returns Empty_Node for limited
-- imported project files, otherwise returns the same result as
-- Project_Node_Of.
function Next_With_Clause_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_With_Clause_Of);
-- Only valid for N_With_Clause nodes
function First_Declarative_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Declarative_Item_Of);
-- Only valid for N_With_Clause nodes
function Extended_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Extended_Project_Of);
-- Only valid for N_Project_Declaration nodes
function Current_Item_Node
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Current_Item_Node);
-- Only valid for N_Declarative_Item nodes
function Next_Declarative_Item
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Declarative_Item);
-- Only valid for N_Declarative_Item node
function Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Project_Of_Renamed_Package_Of);
-- Only valid for N_Package_Declaration nodes.
-- May return Empty_Node.
function Next_Package_In_Project
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Package_In_Project);
-- Only valid for N_Package_Declaration nodes
function First_Literal_String
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Literal_String);
-- Only valid for N_String_Type_Declaration nodes
function Next_String_Type
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_String_Type);
-- Only valid for N_String_Type_Declaration nodes
function Next_Literal_String
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Literal_String);
-- Only valid for N_Literal_String nodes
function Expression_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Expression_Of);
-- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
-- or N_Variable_Declaration nodes
@@ -290,104 +378,88 @@ package Prj.Tree is
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
- Value : Name_Id)
- return Boolean;
+ Value : Name_Id) return Boolean;
pragma Inline (Value_Is_Valid);
-- Only valid for N_Typed_Variable_Declaration. Returns True if Value is
-- in the list of allowed strings for For_Typed_Variable. False otherwise.
function Associative_Array_Index_Of
- (Node : Project_Node_Id)
- return Name_Id;
+ (Node : Project_Node_Id) return Name_Id;
pragma Inline (Associative_Array_Index_Of);
-- Only valid for N_Attribute_Declaration and N_Attribute_Reference.
-- Returns No_String for non associative array attributes.
function Next_Variable
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Variable);
-- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
-- nodes.
function First_Term
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Term);
-- Only valid for N_Expression nodes
function Next_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Expression_In_List);
-- Only valid for N_Expression nodes
function Current_Term
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Current_Term);
-- Only valid for N_Term nodes
function Next_Term
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Term);
-- Only valid for N_Term nodes
function First_Expression_In_List
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Expression_In_List);
-- Only valid for N_Literal_String_List nodes
function Package_Node_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Package_Node_Of);
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
-- May return Empty_Node.
function String_Type_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (String_Type_Of);
-- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
-- nodes.
function External_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (External_Reference_Of);
-- Only valid for N_External_Value nodes
function External_Default_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (External_Default_Of);
-- Only valid for N_External_Value nodes
function Case_Variable_Reference_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Case_Variable_Reference_Of);
-- Only valid for N_Case_Construction nodes
function First_Case_Item_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Case_Item_Of);
-- Only valid for N_Case_Construction nodes
function First_Choice_Of
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (First_Choice_Of);
-- Return the first choice in a N_Case_Item, or Empty_Node if
-- this is when others.
function Next_Case_Item
- (Node : Project_Node_Id)
- return Project_Node_Id;
+ (Node : Project_Node_Id) return Project_Node_Id;
pragma Inline (Next_Case_Item);
-- Only valid for N_Case_Item nodes
@@ -419,6 +491,35 @@ package Prj.Tree is
To : Source_Ptr);
pragma Inline (Set_Location_Of);
+ procedure Set_First_Comment_After
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_After);
+
+ procedure Set_First_Comment_After_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_After_End);
+
+ procedure Set_First_Comment_Before
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_Before);
+
+ procedure Set_First_Comment_Before_End
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_First_Comment_Before_End);
+
+ procedure Set_Next_Comment
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_Next_Comment);
+
+ procedure Set_Project_File_Includes_Unkept_Comments
+ (Node : Project_Node_Id;
+ To : Boolean);
+
procedure Set_Directory_Of
(Node : Project_Node_Id;
To : Name_Id);
@@ -687,14 +788,32 @@ package Prj.Tree is
Field3 : Project_Node_Id := Empty_Node;
-- See below the meaning for each Project_Node_Kind
- Case_Insensitive : Boolean := False;
- -- This flag is significant only for N_Attribute_Declaration and
- -- N_Atribute_Reference. It indicates for an associative array
- -- attribute, that the index is case insensitive.
-
- Extending_All : Boolean := False;
- -- This flag is significant only for N_Project. It indicates that
- -- the project "extends all" another project.
+ Flag1 : Boolean := False;
+ -- This flag is significant only for:
+ -- N_Attribute_Declaration and N_Atribute_Reference
+ -- It indicates for an associative array attribute, that the
+ -- index is case insensitive.
+ -- N_Comment - it indicates that the comment is preceded by an
+ -- empty line.
+ -- N_Project - it indicates that there are comments in the project
+ -- source that cannot be kept in the tree.
+ -- N_Project_Declaration
+ -- - it indixates that there are unkept comment in the
+ -- project.
+
+ Flag2 : Boolean := False;
+ -- This flag is significant only for:
+ -- N_Project - it indicates that the project "extends all" another
+ -- project.
+ -- N_Comment - it indicates that the comment is followed by an
+ -- empty line.
+
+ Comments : Project_Node_Id := Empty_Node;
+ -- For nodes other that N_Comment_Zones or N_Comment, designates the
+ -- comment zones associated with the node.
+ -- for N_Comment_Zones, designates the comment after the "end" of
+ -- the construct.
+ -- For N_Comment, designates the next comment, if any.
end record;
@@ -862,7 +981,7 @@ package Prj.Tree is
-- -- Field3: not used
-- -- Value: not used
- -- N_Case_Item);
+ -- N_Case_Item
-- -- Name: not used
-- -- Path_Name: not used
-- -- Expr_Kind: not used
@@ -872,6 +991,28 @@ package Prj.Tree is
-- -- Field3: next case item
-- -- Value: not used
+ -- N_Comment_zones
+ -- -- Name: not used
+ -- -- Path_Name: not used
+ -- -- Expr_Kind: not used
+ -- -- Field1: comment before the construct
+ -- -- Field2: comment after the construct
+ -- -- Field3: comment before the "end" of the construct
+ -- -- Value: end of line comment
+ -- -- Comments: comment after the "end" of the construct
+
+ -- N_Comment
+ -- -- Name: not used
+ -- -- Path_Name: not used
+ -- -- Expr_Kind: not used
+ -- -- Field1: not used
+ -- -- Field2: not used
+ -- -- Field3: not used
+ -- -- Value: comment
+ -- -- Flag1: comment is preceded by an empty line
+ -- -- Flag2: comment is followed by an empty line
+ -- -- Comments: next comment
+
package Project_Nodes is
new Table.Table (Table_Component_Type => Project_Node_Record,
Table_Index_Type => Project_Node_Id,
@@ -910,5 +1051,21 @@ package Prj.Tree is
-- its name.
end Tree_Private_Part;
+
+private
+ type Comment_Array is array (Positive range <>) of Comment_Data;
+ type Comments_Ptr is access Comment_Array;
+
+ type Comment_State is record
+ End_Of_Line_Node : Project_Node_Id := Empty_Node;
+
+ Previous_Line_Node : Project_Node_Id := Empty_Node;
+
+ Previous_End_Node : Project_Node_Id := Empty_Node;
+
+ Unkept_Comments : Boolean := False;
+
+ Comments : Comments_Ptr := null;
+ end record;
end Prj.Tree;
Index: scans.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scans.ads,v
retrieving revision 1.8
diff -u -p -r1.8 scans.ads
--- scans.ads 21 Oct 2003 13:42:18 -0000 1.8
+++ scans.ads 8 Dec 2003 10:31:51 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -187,15 +187,21 @@ package Scans is
Tok_Dot_Dot, -- .. Sterm, Chtok
- -- The following three entries are used only when scanning
- -- project files.
+ -- The following three entries are used only when scanning project
+ -- files.
Tok_Project,
Tok_Extends,
Tok_External,
+ Tok_Comment,
+
+ -- The following entry is used by the preprocessor and when scanning
+ -- project files.
- -- The following two entries are used by the preprocessor
Tok_End_Of_Line,
+
+ -- The following entry is used by the preprocessor
+
Tok_Special,
No_Token);
@@ -403,6 +409,10 @@ package Scans is
Special_Character : Character;
-- Valid only when Token = Tok_Special
+
+ Comment_Id : Name_Id := No_Name;
+ -- Valid only when Token = Tok_Comment. Store the string that follows
+ -- the two '-' of a comment.
--------------------------------------------------------
-- Procedures for Saving and Restoring the Scan State --
Index: scng.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scng.adb,v
retrieving revision 1.1
diff -u -p -r1.1 scng.adb
--- scng.adb 21 Oct 2003 13:42:18 -0000 1.1
+++ scng.adb 8 Dec 2003 10:31:51 -0000
@@ -49,6 +49,9 @@ package body Scng is
Special_Characters : array (Character) of Boolean := (others => False);
-- For characters that are Special token, the value is True
+ Comment_Is_Token : Boolean := False;
+ -- True if comments are tokens
+
End_Of_Line_Is_Token : Boolean := False;
-- True if End_Of_Line is a token
@@ -229,6 +232,8 @@ package body Scng is
procedure Scan is
+ Start_Of_Comment : Source_Ptr;
+
procedure Check_End_Of_Line;
-- Called when end of line encountered. Checks that line is not
-- too long, and that other style checks for the end of line are met.
@@ -1394,6 +1399,7 @@ package body Scng is
else -- Source (Scan_Ptr + 1) = '-' then
if Style_Check then Style.Check_Comment; end if;
Scan_Ptr := Scan_Ptr + 2;
+ Start_Of_Comment := Scan_Ptr;
-- Loop to scan comment (this loop runs more than once only if
-- a horizontal tab or other non-graphic character is scanned)
@@ -1449,9 +1455,18 @@ package body Scng is
end loop;
- -- Note that we do NOT execute a return here, instead we fall
- -- through to reexecute the scan loop to look for a token.
-
+ -- Note that, except when comments are tokens, we do NOT
+ -- execute a return here, instead we fall through to reexecute
+ -- the scan loop to look for a token.
+
+ if Comment_Is_Token then
+ Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
+ Name_Buffer (1 .. Name_Len) :=
+ String (Source (Start_Of_Comment .. Scan_Ptr - 1));
+ Comment_Id := Name_Find;
+ Token := Tok_Comment;
+ return;
+ end if;
end if;
end Minus_Case;
@@ -2066,6 +2081,14 @@ package body Scng is
return;
end if;
end Scan;
+ --------------------------
+ -- Set_Comment_As_Token --
+ --------------------------
+
+ procedure Set_Comment_As_Token (Value : Boolean) is
+ begin
+ Comment_Is_Token := Value;
+ end Set_Comment_As_Token;
------------------------------
-- Set_End_Of_Line_As_Token --
Index: scng.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/scng.ads,v
retrieving revision 1.1
diff -u -p -r1.1 scng.ads
--- scng.ads 21 Oct 2003 13:42:18 -0000 1.1
+++ scng.ads 8 Dec 2003 10:31:51 -0000
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -90,6 +90,10 @@ package Scng is
procedure Set_End_Of_Line_As_Token (Value : Boolean);
-- Indicate if End_Of_Line is a token or not.
-- By default, End_Of_Line is not a token.
+
+ procedure Set_Comment_As_Token (Value : Boolean);
+ -- Indicate if a comment is a token or not.
+ -- By default, a comment is not a token.
function Set_Start_Column return Column_Number;
-- This routine is called with Scan_Ptr pointing to the first character
Index: sem_aggr.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_aggr.adb,v
retrieving revision 1.11
diff -u -p -r1.11 sem_aggr.adb
--- sem_aggr.adb 20 Nov 2003 09:54:00 -0000 1.11
+++ sem_aggr.adb 8 Dec 2003 10:31:51 -0000
@@ -29,6 +29,7 @@ with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
@@ -334,7 +335,7 @@ package body Sem_Aggr is
--
-- Typ is the context type in which N occurs.
--
- -- This routine creates an implicit array subtype whose bouds are
+ -- This routine creates an implicit array subtype whose bounds are
-- those defined by the aggregate. When this routine is invoked
-- Resolve_Array_Aggregate has already processed aggregate N. Thus the
-- Aggregate_Bounds of each sub-aggregate, is an N_Range node giving the
@@ -962,6 +963,8 @@ package body Sem_Aggr is
-- formal parameter. Consequently we also need to test for
-- N_Procedure_Call_Statement or N_Function_Call.
+ Set_Etype (N, Aggr_Typ); -- may be overridden later on.
+
if Is_Constrained (Typ) and then
(Pkind = N_Assignment_Statement or else
Pkind = N_Parameter_Association or else
@@ -1641,9 +1644,27 @@ package body Sem_Aggr is
end if;
end loop;
- if not
- Resolve_Aggr_Expr
- (Expression (Assoc), Single_Elmt => Single_Choice)
+ -- Ada0Y (AI-287): In case of default initialized component
+ -- we delay the resolution to the expansion phase
+
+ if Box_Present (Assoc) then
+
+ -- Ada0Y (AI-287): In case of default initialization of a
+ -- component the expander will generate calls to the
+ -- corresponding initialization subprogram.
+
+ if Present (Base_Init_Proc (Etype (Component_Typ)))
+ or else Has_Task (Base_Type (Component_Typ))
+ then
+ null;
+ else
+ Error_Msg_N
+ ("(Ada 0Y): no value supplied for this component",
+ Assoc);
+ end if;
+
+ elsif not Resolve_Aggr_Expr (Expression (Assoc),
+ Single_Elmt => Single_Choice)
then
return Failure;
end if;
@@ -1764,8 +1785,26 @@ package body Sem_Aggr is
if Others_Present then
Assoc := Last (Component_Associations (N));
- if not Resolve_Aggr_Expr (Expression (Assoc),
- Single_Elmt => False)
+
+ -- Ada0Y (AI-287): In case of default initialized component
+ -- we delay the resolution to the expansion phase.
+
+ if Box_Present (Assoc) then
+
+ -- Ada0Y (AI-287): In case of default initialization of a
+ -- component the expander will generate calls to the
+ -- corresponding initialization subprogram.
+
+ if Present (Base_Init_Proc (Etype (Component_Typ))) then
+ null;
+ else
+ Error_Msg_N
+ ("(Ada 0Y): no value supplied for these components",
+ Assoc);
+ end if;
+
+ elsif not Resolve_Aggr_Expr (Expression (Assoc),
+ Single_Elmt => False)
then
return Failure;
end if;
Index: sem_ch12.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch12.adb,v
retrieving revision 1.28
diff -u -p -r1.28 sem_ch12.adb
--- sem_ch12.adb 20 Nov 2003 09:54:01 -0000 1.28
+++ sem_ch12.adb 8 Dec 2003 10:31:52 -0000
@@ -1466,7 +1466,10 @@ package body Sem_Ch12 is
end if;
if K = E_Generic_In_Parameter then
- if Is_Limited_Type (T) then
+
+ -- Ada0Y (AI-287): Limited aggregates allowed in generic formals
+
+ if not Extensions_Allowed and then Is_Limited_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of limited type", N);
Explain_Limited_Type (T, N);
Index: sem_ch3.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch3.adb,v
retrieving revision 1.24
diff -u -p -r1.24 sem_ch3.adb
--- sem_ch3.adb 27 Nov 2003 11:40:45 -0000 1.24
+++ sem_ch3.adb 8 Dec 2003 10:31:53 -0000
@@ -6246,6 +6246,7 @@ package body Sem_Ch3 is
if (Is_Limited_Type (T)
or else Is_Limited_Composite (T))
and then not In_Instance
+ and then not In_Inlined_Body
then
-- Ada0Y (AI-287): Relax the strictness of the front-end in case of
-- limited aggregates and extension aggregates.
@@ -8438,18 +8439,6 @@ package body Sem_Ch3 is
Init_Size_Align (Implicit_Base);
- -- Complete entity for first subtype
-
- Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
- Set_Etype (T, Implicit_Base);
- Set_Size_Info (T, Implicit_Base);
- Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
- Set_Digits_Value (T, Digs_Val);
- Set_Delta_Value (T, Delta_Val);
- Set_Small_Value (T, Delta_Val);
- Set_Scale_Value (T, Scale_Val);
- Set_Is_Constrained (T);
-
-- If there are bounds given in the declaration use them as the
-- bounds of the first named subtype.
@@ -8491,6 +8480,18 @@ package body Sem_Ch3 is
else
Set_Fixed_Range (T, Loc, -Bound_Val, Bound_Val);
end if;
+
+ -- Complete entity for first subtype
+
+ Set_Ekind (T, E_Decimal_Fixed_Point_Subtype);
+ Set_Etype (T, Implicit_Base);
+ Set_Size_Info (T, Implicit_Base);
+ Set_First_Rep_Item (T, First_Rep_Item (Implicit_Base));
+ Set_Digits_Value (T, Digs_Val);
+ Set_Delta_Value (T, Delta_Val);
+ Set_Small_Value (T, Delta_Val);
+ Set_Scale_Value (T, Scale_Val);
+ Set_Is_Constrained (T);
end Decimal_Fixed_Point_Type_Declaration;
Index: sem_util.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_util.adb,v
retrieving revision 1.15
diff -u -p -r1.15 sem_util.adb
--- sem_util.adb 20 Nov 2003 09:54:01 -0000 1.15
+++ sem_util.adb 8 Dec 2003 10:31:53 -0000
@@ -6371,6 +6371,9 @@ package body Sem_Util is
Error_Msg_N (
"operator of the type is not directly visible!", Expr);
+ elsif Ekind (Found_Type) = E_Void then
+ Error_Msg_NE ("found premature usage of}!", Expr, Found_Type);
+
else
Error_Msg_NE ("found}!", Expr, Found_Type);
end if;
Index: sinput-p.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sinput-p.adb,v
retrieving revision 1.5
diff -u -p -r1.5 sinput-p.adb
--- sinput-p.adb 21 Oct 2003 13:42:22 -0000 1.5
+++ sinput-p.adb 8 Dec 2003 10:31:53 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -24,7 +24,6 @@
-- --
------------------------------------------------------------------------------
-with Prj; use Prj;
with Prj.Err;
with Sinput.C;
@@ -97,7 +96,7 @@ package body Sinput.P is
or else Token = Tok_Private
or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
loop
- Scan;
+ Prj.Err.Scanner.Scan;
end loop;
return Token = Tok_Separate;
Index: targparm.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/targparm.ads,v
retrieving revision 1.6
diff -u -p -r1.6 targparm.ads
--- targparm.ads 21 Oct 2003 13:42:22 -0000 1.6
+++ targparm.ads 8 Dec 2003 10:31:53 -0000
@@ -322,12 +322,6 @@ package Targparm is
--
-- The variable __gnat_exit_status is generated within the binder file
-- instead of being imported from the run-time library.
- --
- -- No -Ldir switches are added for the linker step
- --
- -- No standard switches are added after user file entries to the
- -- linker line. All such switches must be explicit. In other words
- -- the option -nostdlib is implicit with a configurable run-time.
Suppress_Standard_Library_On_Target : Boolean;
-- If this flag is True, then the standard library is not included by
Index: Makefile.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Makefile.in,v
retrieving revision 1.58
diff -u -p -r1.58 Makefile.in
--- Makefile.in 5 Dec 2003 10:24:05 -0000 1.58
+++ Makefile.in 8 Dec 2003 10:31:53 -0000
@@ -1843,6 +1843,8 @@ rts-zfp: force
-$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
$(RM) rts-zfp/adalib/*.o
$(CHMOD) a-wx rts-zfp/adalib/*.ali
+ $(AR) r rts-zfp/adalib/libgnat.a
+ $(CHMOD) a-wx rts-zfp/adalib/libgnat.a
rts-none: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
@@ -1861,6 +1863,8 @@ rts-ravenscar: force
-$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
--GCC="../../../xgcc -B../../../"
$(CHMOD) a-wx rts-ravenscar/adalib/*.ali
+ $(AR) r rts-ravenscar/adalib/libgnat.a
+ $(CHMOD) a-wx rts-ravenscar/adalib/libgnat.a
# Warning: this target assumes that LIBRARY_VERSION has been set correctly.
gnatlib-shared-default:
Index: Make-lang.in
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/Make-lang.in,v
retrieving revision 1.61
diff -u -p -r1.61 Make-lang.in
--- Make-lang.in 5 Dec 2003 10:24:04 -0000 1.61
+++ Make-lang.in 8 Dec 2003 10:31:53 -0000
@@ -915,8 +915,8 @@ ada.distclean:
-$(RM) ada/tools/*
-$(RMDIR) ada/tools
ada.maintainer-clean:
- -$(RM) ada/a-sinfo.h
- -$(RM) ada/a-einfo.h
+ -$(RM) ada/sinfo.h
+ -$(RM) ada/einfo.h
-$(RM) ada/nmake.adb
-$(RM) ada/nmake.ads
-$(RM) ada/treeprs.ads
@@ -1213,6 +1213,11 @@ ada/a-charac.o : ada/ada.ads ada/a-chara
ada/a-chlat1.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
ada/system.ads
+ada/a-elchha.o : ada/ada.ads ada/a-except.ads ada/a-elchha.ads \
+ ada/a-elchha.adb ada/system.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traent.ads ada/unchconv.ads
+
ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \
ada/a-excach.adb ada/a-exexda.adb ada/a-exexpr.adb ada/a-exextr.adb \
ada/a-excpol.adb ada/a-exstat.adb ada/a-unccon.ads ada/a-uncdea.ads \
@@ -1525,26 +1530,26 @@ ada/exp_aggr.o : ada/ada.ads ada/a-excep
ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \
ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch11.ads ada/exp_ch2.ads \
- ada/exp_ch3.ads ada/exp_ch7.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/exp_util.adb ada/expander.ads ada/fname.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
- ada/lib-sort.adb ada/namet.ads ada/nlists.ads ada/nlists.adb \
- ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads \
- ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb \
- ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \
- ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \
- ada/sprint.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
- ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/validsw.ads
+ ada/exp_ch3.ads ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_tss.ads \
+ ada/exp_util.ads ada/exp_util.adb ada/expander.ads ada/fname.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
+ ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/nlists.ads \
+ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \
+ ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
+ ada/snames.ads ada/sprint.ads ada/stand.ads ada/stringt.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
+ ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads \
@@ -1679,13 +1684,13 @@ ada/exp_ch3.o : ada/ada.ads ada/a-except
ada/sem_intr.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_res.adb \
ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
- ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
- ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-rident.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads ada/s-unstyp.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
+ ada/stand.ads ada/stringt.ads ada/stringt.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-memory.ads \
+ ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traent.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads \
+ ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \