diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2003-12-08 10:33:17 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2003-12-08 10:33:17 +0000 |
| commit | bdd64cbef403677f46362009e2b592176d04d22d (patch) | |
| tree | c83150f858a1ea22febff15880c94d93b7c3314f /gcc | |
| parent | 75213f6909b7f4c460932a1ec9b29b575627818d (diff) | |
| download | ppe42-gcc-bdd64cbef403677f46362009e2b592176d04d22d.tar.gz ppe42-gcc-bdd64cbef403677f46362009e2b592176d04d22d.zip | |
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
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@74414 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
37 files changed, 2135 insertions, 1436 deletions
diff --git a/gcc/ada/5ytiitho.adb b/gcc/ada/5ytiitho.adb deleted file mode 100644 index ad2924d559d..00000000000 --- a/gcc/ada/5ytiitho.adb +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T H R E A D S . I N I T I A L I Z A T I O N . -- --- I N I T I A L I Z E _ T A S K _ H O O K S -- --- -- --- B o d y -- --- -- --- 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks AE 653 version of this procedure - -separate (System.Threads.Initialization) -procedure Initialize_Task_Hooks is - - -- When defining the following routine for export in an AE 1.1 - -- simulation of AE653, Interfaces.C.int may be used for the - -- parameters of FUNCPTR. - type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS; - - -------------------------------- - -- Imported vThreads Routines -- - -------------------------------- - - procedure procCreateHookAdd (createHookFunction : FUNCPTR); - pragma Import (C, procCreateHookAdd, "procCreateHookAdd"); - -- Registers task registration routine for AE653 - -begin - -- Register the exported routine with the vThreads ARINC API - procCreateHookAdd (Register'Access); -end Initialize_Task_Hooks; diff --git a/gcc/ada/5zthrini.adb b/gcc/ada/5zthrini.adb deleted file mode 100644 index e0bffe09d6c..00000000000 --- a/gcc/ada/5zthrini.adb +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T H R E A D S . I N I T I A L I Z A T I O N -- --- -- --- B o d y -- --- -- --- 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks version of this package; to use this implementation, --- the task hook libraries should be included in the VxWorks kernel. - -with System.Secondary_Stack; -with System.Storage_Elements; -with System.Soft_Links; -with Interfaces.C; - -package body System.Threads.Initialization is - - use Interfaces.C; - - package SSS renames System.Secondary_Stack; - - package SSL renames System.Soft_Links; - - procedure Initialize_Task_Hooks; - -- Register the appropriate hooks (Register and Reset_TSD) to the - -- underlying OS, so that they will be called when a task is created - -- or reset. - - Current_ATSD : aliased System.Address; - pragma Import (C, Current_ATSD, "__gnat_current_atsd"); - - --------------------------- - -- Initialize_Task_Hooks -- - --------------------------- - - procedure Initialize_Task_Hooks is separate; - -- Separate, as these hooks are different for AE653 and VxWorks 5.5. - - -------------- - -- Init_RTS -- - -------------- - - procedure Init_RTS is - begin - SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; - SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; - SSL.Get_Current_Excep := Get_Current_Excep'Access; - SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; - SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; - end Init_RTS; - - -------------- - -- Register -- - -------------- - - function Register (T : OSI.Thread_Id) return OSI.STATUS is - Result : OSI.STATUS; - begin - -- It cannot be assumed that the caller of this routine has a ATSD; - -- so neither this procedure nor the procedures that it calls should - -- raise or handle exceptions, or make use of a secondary stack. - - -- This routine is only necessary because taskVarAdd cannot be - -- executed once an AE653 partition has entered normal mode - -- (depending on configRecord.c, allocation could be disabled). - -- Otherwise, everything could have been done in Thread_Body_Enter. - - if OSI.taskIdVerify (T) = OSI.ERROR then - return OSI.ERROR; - end if; - - Result := OSI.taskVarAdd (T, Current_ATSD'Access); - pragma Assert (Result /= OSI.ERROR); - - return Result; - end Register; - - subtype Default_Sec_Stack is - System.Storage_Elements.Storage_Array - (1 .. SSS.Default_Secondary_Stack_Size); - - Main_Sec_Stack : aliased Default_Sec_Stack; - - -- Secondary stack for environment task - - Main_ATSD : aliased ATSD; - - -- TSD for environment task - -begin - Initialize_Task_Hooks; - - -- Register the environment task - declare - Result : Interfaces.C.int := Register (OSI.taskIdSelf); - pragma Assert (Result /= OSI.ERROR); - begin - Thread_Body_Enter - (Main_Sec_Stack'Address, - Main_Sec_Stack'Size / System.Storage_Unit, - Main_ATSD'Address); - end; -end System.Threads.Initialization; diff --git a/gcc/ada/5ztiitho.adb b/gcc/ada/5ztiitho.adb deleted file mode 100644 index bda356e16a4..00000000000 --- a/gcc/ada/5ztiitho.adb +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T H R E A D S . I N I T I A L I Z A T I O N . -- --- I N I T I A L I Z E _ T A S K _ H O O K S -- --- -- --- B o d y -- --- -- --- 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks 5.5 version of this procedure - -separate (System.Threads.Initialization) - -procedure Initialize_Task_Hooks is - - type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS; - - procedure taskCreateHookAdd (createHookFunction : FUNCPTR); - pragma Import (C, taskCreateHookAdd, "taskCreateHookAdd"); - -begin - taskCreateHookAdd (Register'Access); -end Initialize_Task_Hooks; diff --git a/gcc/ada/7sintman.adb b/gcc/ada/7sintman.adb index 4e9b6d08635..801adac39f2 100644 --- a/gcc/ada/7sintman.adb +++ b/gcc/ada/7sintman.adb @@ -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 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fac9736a760..6d3c2b33436 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,169 @@ +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 + 2003-12-08 Arnaud Charlet <charlet@act-europe.fr> * sinfo.h, einfo.h, nmake.ads, treeprs.ads: Removed, since they diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in index 8dcd896282a..e165cdb96ef 100644 --- a/gcc/ada/Make-lang.in +++ b/gcc/ada/Make-lang.in @@ -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-charac.ads ada/system.ads 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-except.ads ada/alloc.ads ada/atree.ads \ 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.ads ada/alloc.ads ada/atree.ads \ 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 \ diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 28f2bea0661..4d5b44330fa 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -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: diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index bfb4a69ec36..56b2915ef6f 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -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 + -- Add a "-Ldir" for each directory in the object path - 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; + 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 diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index cf24a629f17..9c233995c8f 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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. - declare - P : Node_Id := Parent (Expr); + if Present (Expr) then - begin - while Present (P) loop + -- This is a multidimensional array. Recover the component + -- type from the outermost aggregate, because subaggregates + -- do not have an assigned type. - if Nkind (P) = N_Aggregate - and then Present (Etype (P)) - then - Comp_Type := Component_Type (Etype (P)); - exit; + declare + P : Node_Id := Parent (Expr); - else - P := Parent (P); - end if; - end loop; - end; + begin + while Present (P) loop + + 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; + 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)), + Name => Indexed_Comp, + Expression => New_Copy_Tree (Expr)); - Expression => - Unchecked_Convert_To (RTE (RE_Tag), - New_Reference_To ( - Access_Disp_Table (Comp_Type), Loc))); + 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. + -- Ada0Y (AI-287): Nothing else need to be done in case of + -- default initialized component - 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; + 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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3fd7225fb0a..1cb9328655c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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??? + + 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); + 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; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 6d94e1a714b..7de6498a696 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -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 diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 08c824dcedd..f8bf7f80a6c 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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; diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 76a888ed6d7..72060781470 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -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- -- @@ -164,6 +164,15 @@ package Exp_Ch9 is -- 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 -- the name of an access to a concurrent object, this function returns an diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 45dda7404f2..d2378630825 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -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"; diff --git a/gcc/ada/i-vthrea.adb b/gcc/ada/i-vthrea.adb deleted file mode 100644 index 049e1c4bf68..00000000000 --- a/gcc/ada/i-vthrea.adb +++ /dev/null @@ -1,386 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V T H R E A D S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2003, Free Software Foundation, Inc. -- --- -- --- GNARL 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- Implement APEX process registration for AE653 - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.Secondary_Stack; -with System.Soft_Links; -with System.Task_Primitives.Ae_653; -with System.Task_Primitives.Operations; use System.Task_Primitives.Operations; -with System.Tasking; use System.Tasking; -with System.Task_Info; -with System.Tasking.Initialization; - -package body Interfaces.Vthreads is - - use System.OS_Interface; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Enter_Task (T : Task_ID; Thread : Thread_Id); - -- Duplicate and generalize - -- System.Task_Primitives.Operations.Enter_Task - - procedure GNAT_Error_Handler (Sig : Signal); - -- Signal handler for ARINC processes - - procedure Init_Float; - pragma Import (C, Init_Float, "__gnat_init_float"); - -- Properly initializes the FPU for PPC systems. - - procedure Install_Handler; - -- Install signal handlers for the calling ARINC process - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Duplicate and generalize - -- System.Task_Primitives.Operations.Register_Foreign_Thread - - ----------------------------- - -- Install_Signal_Handlers -- - ----------------------------- - - function Install_Signal_Handlers return Interfaces.C.int is - begin - Install_Handler; - Init_Float; - return 0; - end Install_Signal_Handlers; - - ---------------------- - -- Register_Foreign -- - ---------------------- - - -- Create Ada task data structures for an ARINC process. All dynamic - -- allocation of related data structures must be done via this routine. - - function Register_Foreign (T : OSI.Thread_Id) return OSI.STATUS is - use Interfaces.C; - use System.Task_Primitives.Ae_653; - - pragma Assert (taskVarGet (T, ATCB_Key_Addr) = ERROR); - -- "T" is not yet registered - - Result : OSI.STATUS := taskIdVerify (T); - Status : OSI.STATUS := OK; - Temp_Id : Task_ID; - - begin - if Result = OK then - Status := taskVarGet (T, ATCB_Key_Addr); - - -- Error of already registered - - if Status /= ERROR then - Result := ERROR; - - else - -- Create a TCB - - declare - -- Make sure the caller has a TCB, since it's possible to have - -- pure C APEX processes that create ones calling Ada code - - Caller : Task_ID; - - begin - Status := taskVarGet (taskIdSelf, ATCB_Key_Addr); - - if Status = ERROR then - Caller := Register_Foreign_Thread (taskIdSelf); - end if; - end; - - if taskIdSelf /= T then - Temp_Id := Register_Foreign_Thread (T); - end if; - - Result := OK; - end if; - end if; - - return Result; - end Register_Foreign; - - ------------------- - -- Reset_Foreign -- - ------------------- - - -- Reinitialize Ada task data structures. No dynamic allocation - -- may occur via this routine. - - function Reset_Foreign (T : Thread_Id) return STATUS is - use Interfaces.C; - use System.Secondary_Stack; - use System.Task_Primitives.Ae_653; - use type System.Address; - - pragma Assert (taskVarGet (T, ATCB_Key_Addr) /= ERROR); - -- "T" has already been registered - - Result : STATUS := taskVarGet (T, ATCB_Key_Addr); - function To_Address is new Ada.Unchecked_Conversion - (Interfaces.C.int, System.Address); - - pragma Assert ( - To_Task_Id - (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr - /= System.Null_Address); - -- "T" already has a secondary stack - - begin - if Result /= ERROR then - - -- Just reset the secondary stack pointer. The implementation here - -- assumes that the fixed secondary stack implementation is used. - -- If not, there will be a memory leak (along with allocation, which - -- is prohibited for ARINC processes once the system enters "normal" - -- mode). - - SS_Init - (To_Task_Id - (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr); - Result := OK; - end if; - - return Result; - end Reset_Foreign; - - ------------------ - -- Setup_Thread -- - ------------------ - - function Setup_Thread return System.Address is - Result : System.Address := System.Null_Address; - Status : OSI.STATUS; - - begin - if Is_Valid_Task then - Status := Reset_Foreign (taskIdSelf); - Result := - To_Address (System.Task_Primitives.Operations.Self); - else - Status := Register_Foreign (taskIdSelf); - Install_Handler; - Init_Float; - Result := - To_Address (System.Task_Primitives.Operations.Self); - end if; - - return Result; - end Setup_Thread; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (T : Task_ID; Thread : Thread_Id) is - use System.Task_Primitives.Ae_653; - - begin - Set_Task_Thread (T, Thread); - end Enter_Task; - - ------------------------ - -- GNAT_Error_Handler -- - ------------------------ - - procedure GNAT_Error_Handler (Sig : Signal) is - Mask : aliased sigset_t; - Result : int; - - begin - -- This code is the Ada replacement for init.c in the - -- AE653 level B runtime. - - -- VxWorks will always mask out the signal during the signal - -- handler and will reenable it on a longjmp. GNAT does not - -- generate a longjmp to return from a signal handler so the - -- signal will still be masked unless we unmask it. - - Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); - Result := sigdelset (Mask'Access, Sig); - Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); - - case Sig is - when SIGFPE => - Raise_Exception (Constraint_Error'Identity, "SIGFPE"); - when SIGILL => - Raise_Exception (Constraint_Error'Identity, "SIGILL"); - when SIGSEGV => - Raise_Exception - (Program_Error'Identity, - "erroneous memory access"); - when SIGBUS => - -- SIGBUS indicates stack overflow when it occurs - -- in an application domain (but not in the Core - -- OS under AE653, or in the kernel domain under - -- AE 1.1). - Raise_Exception - (Storage_Error'Identity, - "stack overflow or SIGBUS"); - when others => - Raise_Exception (Program_Error'Identity, "unhandled signal"); - end case; - end GNAT_Error_Handler; - - --------------------- - -- Install_Handler -- - --------------------- - - procedure Install_Handler is - Mask : aliased sigset_t; - Signal_Action : aliased struct_sigaction; - Result : Interfaces.C.int; - - begin - -- Set up signal handler to map synchronous signals to appropriate - -- exceptions. Make sure that the handler isn't interrupted by - -- another signal that might cause a scheduling event! - - -- This code is the Ada replacement for init.c in the - -- AE653 level B runtime. - Signal_Action.sa_handler := GNAT_Error_Handler'Address; - Signal_Action.sa_flags := SA_ONSTACK; - Result := sigemptyset (Mask'Access); - Signal_Action.sa_mask := Mask; - - Result := sigaction - (Signal (SIGFPE), Signal_Action'Unchecked_Access, null); - - Result := sigaction - (Signal (SIGILL), Signal_Action'Unchecked_Access, null); - - Result := sigaction - (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null); - - Result := sigaction - (Signal (SIGBUS), Signal_Action'Unchecked_Access, null); - - end Install_Handler; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - Foreign_Task_Elaborated : aliased Boolean := True; - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID is - pragma Assert (Thread = taskIdSelf or else Is_Valid_Task); - -- Ensure that allocation will work - - Local_ATCB : aliased Ada_Task_Control_Block (0); - New_Id : Task_ID; - Succeeded : Boolean; - - use type Interfaces.C.unsigned; - use type System.Address; - use System.Task_Info; - use System.Task_Primitives.Ae_653; - - begin - if taskIdSelf = Thread then - declare - Self : Task_ID := Local_ATCB'Unchecked_Access; - -- Temporarily record this as the Task_ID for the thread - - begin - Set_Current_Priority (Self, System.Priority'First); - Set_Task_Thread (Self, Thread); - end; - end if; - - pragma Assert (Is_Valid_Task); - -- It is now safe to use an allocator for the real TCB - - New_Id := new Ada_Task_Control_Block (0); - - -- Finish initialization - - System.Tasking.Initialize_ATCB - (New_Id, null, System.Null_Address, Null_Task, - Foreign_Task_Elaborated'Access, - System.Priority'First, - System.Task_Info.Unspecified_Task_Info, 0, New_Id, - Succeeded); - pragma Assert (Succeeded); - - New_Id.Master_of_Task := 0; - New_Id.Master_Within := New_Id.Master_of_Task + 1; - - for L in New_Id.Entry_Calls'Range loop - New_Id.Entry_Calls (L).Self := New_Id; - New_Id.Entry_Calls (L).Level := L; - end loop; - - New_Id.Common.State := Runnable; - New_Id.Awake_Count := 1; - - -- Since this is not an ordinary Ada task, we will start out undeferred - - New_Id.Deferral_Level := 0; - - System.Soft_Links.Create_TSD (New_Id.Common.Compiler_Data); - - -- Allocate a fixed secondary stack - - pragma Assert - (New_Id.Common.Compiler_Data.Sec_Stack_Addr = System.Null_Address); - System.Secondary_Stack.SS_Init - (New_Id.Common.Compiler_Data.Sec_Stack_Addr); - - Enter_Task (New_Id, Thread); - - return New_Id; - end Register_Foreign_Thread; - - -- Force use of tasking versions of secondary stack routines: - - procedure Force_Closure renames - System.Tasking.Initialization.Defer_Abortion; - pragma Unreferenced (Force_Closure); - --- Package elaboration code - -begin - -- Register the exported routines with the vThreads ARINC API - - procCreateHookAdd (Register_Foreign'Access); - procStartHookAdd (Reset_Foreign'Access); -end Interfaces.Vthreads; diff --git a/gcc/ada/i-vthrea.ads b/gcc/ada/i-vthrea.ads deleted file mode 100644 index d4a79757cfe..00000000000 --- a/gcc/ada/i-vthrea.ads +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V T H R E A D S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2003, Free Software Foundation, Inc. -- --- -- --- GNARL 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- Implement APEX process registration for AE653. The routines exported --- by this package are only called from the APEX CREATE and START routines --- in the AE653 vThreads API. A context clause for this unit must appear in --- the Ada APEX binding. --- --- If this package appears in a context clause for an application that will --- be run in a non-AE653 version of VxWorks, or in a non-vThreads AE653 --- partition, link or load errors for the symbols procCreateHookAdd and --- procStartHookAdd will occur, unless these routines are defined --- in the application. This is used when simulating AE653 in AE 1.1. - -with System.OS_Interface; -with Interfaces.C; - -package Interfaces.Vthreads is - - function Setup_Thread return System.Address; - -- Register an existing vxWorks task. This routine is used - -- under AE 1.1 when simulating AE 653. - - function Install_Signal_Handlers return Interfaces.C.int; - pragma Export (C, Install_Signal_Handlers, - "__gnat_install_signal_handlers"); - -- Map the synchronous signals SIGSEGV, SIGFPE, SIGILL and - -- SIGBUS to Ada exceptions for the calling ARINC process. - -- This routine should be called as early as possible in - -- each ARINC process body. - -- C declaration: - -- extern int __gnat_install_signal_handlers (); - -- This call is unnecessary on AE 1.1. - -private - package OSI renames System.OS_Interface; - - function Register_Foreign (T : OSI.Thread_Id) return OSI.STATUS; - -- Create runtime structures necessary for Ada language support for - -- an ARINC process. Called from APEX CREATE routine. - - function Reset_Foreign (T : OSI.Thread_Id) return OSI.STATUS; - -- Reset runtime structures upon an AE653 process restart. Called from - -- APEX START routine. - - -- When defining the following routines for export in an AE 1.1 - -- simulation of AE653, Interfaces.C.int may be used for the - -- parameters of FUNCPTR. - type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS; - - -------------------------------- - -- Imported vThreads Routines -- - -------------------------------- - - procedure procCreateHookAdd (createHookFunction : FUNCPTR); - pragma Import (C, procCreateHookAdd, "procCreateHookAdd"); - -- Registers task registration routine for AE653 - - procedure procStartHookAdd (StartHookFunction : FUNCPTR); - pragma Import (C, procStartHookAdd, "procStartHookAdd"); - -- Registers task restart routine for AE653 - -end Interfaces.Vthreads; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 4fe2ff4b7f3..82eaeb6301d 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -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 diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index f560c8da6a2..838738c9bd9 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -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 diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 9865dff63c1..ac39eeda369 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -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); diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 73d7c574575..1aa4725e46c 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -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; ----------------------- diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads index a4d20faef1a..5b8f3921928 100644 --- a/gcc/ada/prj-part.ads +++ b/gcc/ada/prj-part.ads @@ -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; diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index 8bbc265efc8..1ac45ed28e3 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -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; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb index 74cd73d7b13..7e548e8ce2e 100644 --- a/gcc/ada/prj-tree.adb +++ b/gcc/ada/prj-tree.adb @@ -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 @@ -1706,4 +2442,14 @@ package body Prj.Tree is 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; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads index 15156e869d3..942c10be0b9 100644 --- a/gcc/ada/prj-tree.ads +++ b/gcc/ada/prj-tree.ads @@ -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, @@ -911,4 +1052,20 @@ package Prj.Tree is 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; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index fc817eabd6e..6594b8782ac 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -123,7 +123,8 @@ package body Prj is Seen => False, Flag1 => False, Flag2 => False, - Depth => 0); + Depth => 0, + Unkept_Comments => False); ------------------- -- Add_To_Buffer -- @@ -387,15 +388,6 @@ package body Prj is and then Left.Separate_Suffix = Right.Separate_Suffix; end Same_Naming_Scheme; - ---------- - -- Scan -- - ---------- - - procedure Scan is - begin - Scanner.Scan; - end Scan; - -------------------------- -- Standard_Naming_Data -- -------------------------- diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index b323a86e1c0..3f9033c7b3c 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -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; @@ -610,10 +614,6 @@ package Prj is -- 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 Initial_Buffer_Size : constant := 100; diff --git a/gcc/ada/s-tpae65.adb b/gcc/ada/s-tpae65.adb deleted file mode 100644 index b0438b00fa3..00000000000 --- a/gcc/ada/s-tpae65.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . A E _ 6 5 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2003, Free Software Foundation, Inc. -- --- -- --- GNARL 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- Export certain tasking-related routines for use by Interfaces.Vthreads - -with Interfaces.C; -package body System.Task_Primitives.Ae_653 is - - ------------------- - -- ATCB_Key_Addr -- - ------------------- - - function ATCB_Key_Addr return Address_Access is - Key_Addr : Address_Access; - pragma Import (Ada, Key_Addr, "__gnat_ATCB_key_addr"); - -- Done this way to minimize impact on other targets. This - -- implementation is temporary, and specific to AE653 - begin - return Key_Addr; - end ATCB_Key_Addr; - - -------------------------- - -- Set_Current_Priority -- - -------------------------- - - procedure Set_Current_Priority - (T : System.Tasking.Task_ID; - Prio : System.Priority) - is - begin - T.Common.Current_Priority := Prio; - end Set_Current_Priority; - - --------------------- - -- Set_Task_Thread -- - --------------------- - - procedure Set_Task_Thread - (T : System.Tasking.Task_ID; - Thread : System.OS_Interface.Thread_Id) - is - use System.OS_Interface; - use System.Tasking; - use type Interfaces.C.int; - Result : STATUS; - begin - T.Common.LL.Thread := Thread; - if taskVarGet (Thread, ATCB_Key_Addr) = ERROR then - Result := taskVarAdd (Thread, ATCB_Key_Addr); - pragma Assert (Result = OK); - end if; - - Result := taskVarSet (Thread, ATCB_Key_Addr, To_Address (T)); - pragma Assert (Result = OK); - end Set_Task_Thread; - -end System.Task_Primitives.Ae_653; diff --git a/gcc/ada/s-tpae65.ads b/gcc/ada/s-tpae65.ads deleted file mode 100644 index 641f17187d8..00000000000 --- a/gcc/ada/s-tpae65.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . A E _ 6 5 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2003, Free Software Foundation, Inc. -- --- -- --- GNARL 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- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- Export certain tasking-related routines for use by Interfaces.Vthreads - -with System.Tasking; -with System.OS_Interface; -package System.Task_Primitives.Ae_653 is - type Address_Access is access System.Address; - - function ATCB_Key_Addr return Address_Access; - pragma Inline (ATCB_Key_Addr); - -- Address of ATCB_Key taskvar - - procedure Set_Current_Priority - (T : System.Tasking.Task_ID; Prio : System.Priority); - -- Set priority - - procedure Set_Task_Thread - (T : System.Tasking.Task_ID; - Thread : System.OS_Interface.Thread_Id); - -- Set "Thread" as the underlying OS thread implementing "T" - -end System.Task_Primitives.Ae_653; diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 1551296907e..b8f5c397654 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -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); @@ -404,6 +410,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 -- -------------------------------------------------------- diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 369a6acc944..cb46bf189ee 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -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 -- diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads index 7ebb441f63e..31e81a7cd7f 100644 --- a/gcc/ada/scng.ads +++ b/gcc/ada/scng.ads @@ -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- -- @@ -91,6 +91,10 @@ package Scng is -- 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 -- of a line. On exit, Scan_Ptr is advanced to the first non-blank diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index cb9c2a34c09..897e9b500af 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index c84006d4668..1676ee85491 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index f74480cb34c..f14e049ec75 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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. @@ -8492,6 +8481,18 @@ package body Sem_Ch3 is 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; ----------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 44550392d9a..6183c0cc1a1 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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; diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb index 5edc13bf9ae..89befb6a0c6 100644 --- a/gcc/ada/sinput-p.adb +++ b/gcc/ada/sinput-p.adb @@ -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; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index cf7aa2398ba..942b501af18 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -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 |
