diff options
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 |
